Theory Base
section ‹Base›
theory Base
imports Stone_Relation_Algebras.Semirings
begin
class while =
fixes while :: "'a ⇒ 'a ⇒ 'a" (infixr "⋆" 59)
class n =
fixes n :: "'a ⇒ 'a"
class diamond =
fixes diamond :: "'a ⇒ 'a ⇒ 'a" ("| _ > _" [50,90] 95)
class box =
fixes box :: "'a ⇒ 'a ⇒ 'a" ("| _ ] _" [50,90] 95)
context ord
begin
definition ascending_chain :: "(nat ⇒ 'a) ⇒ bool"
where "ascending_chain f ≡ ∀n . f n ≤ f (Suc n)"
definition descending_chain :: "(nat ⇒ 'a) ⇒ bool"
where "descending_chain f ≡ ∀n . f (Suc n) ≤ f n"
definition directed :: "'a set ⇒ bool"
where "directed X ≡ X ≠ {} ∧ (∀x∈X . ∀y∈X . ∃z∈X . x ≤ z ∧ y ≤ z)"
definition co_directed :: "'a set ⇒ bool"
where "co_directed X ≡ X ≠ {} ∧ (∀x∈X . ∀y∈X . ∃z∈X . z ≤ x ∧ z ≤ y)"
definition chain :: "'a set ⇒ bool"
where "chain X ≡ ∀x∈X . ∀y∈X . x ≤ y ∨ y ≤ x"
end
context order
begin
lemma ascending_chain_k:
"ascending_chain f ⟹ f m ≤ f (m + k)"
apply (induct k)
apply simp
using le_add1 lift_Suc_mono_le ord.ascending_chain_def by blast
lemma ascending_chain_isotone:
"ascending_chain f ⟹ m ≤ k ⟹ f m ≤ f k"
using lift_Suc_mono_le ord.ascending_chain_def by blast
lemma ascending_chain_comparable:
"ascending_chain f ⟹ f k ≤ f m ∨ f m ≤ f k"
by (meson ascending_chain_isotone linear)
lemma ascending_chain_chain:
"ascending_chain f ⟹ chain (range f)"
by (simp add: ascending_chain_comparable chain_def)
lemma chain_directed:
"X ≠ {} ⟹ chain X ⟹ directed X"
by (metis chain_def directed_def)
lemma ascending_chain_directed:
"ascending_chain f ⟹ directed (range f)"
by (simp add: ascending_chain_chain chain_directed)
lemma descending_chain_k:
"descending_chain f ⟹ f (m + k) ≤ f m"
apply (induct k)
apply simp
using le_add1 lift_Suc_antimono_le ord.descending_chain_def by blast
lemma descending_chain_antitone:
"descending_chain f ⟹ m ≤ k ⟹ f k ≤ f m"
using descending_chain_def lift_Suc_antimono_le by blast
lemma descending_chain_comparable:
"descending_chain f ⟹ f k ≤ f m ∨ f m ≤ f k"
by (meson descending_chain_antitone nat_le_linear)
lemma descending_chain_chain:
"descending_chain f ⟹ chain (range f)"
by (simp add: descending_chain_comparable chain_def)
lemma chain_co_directed:
"X ≠ {} ⟹ chain X ⟹ co_directed X"
by (metis chain_def co_directed_def)
lemma descending_chain_codirected:
"descending_chain f ⟹ co_directed (range f)"
by (simp add: chain_co_directed descending_chain_chain)
end
context semilattice_sup
begin
lemma ascending_chain_left_sup:
"ascending_chain f ⟹ ascending_chain (λn . x ⊔ f n)"
using ascending_chain_def sup_right_isotone by blast
lemma ascending_chain_right_sup:
"ascending_chain f ⟹ ascending_chain (λn . f n ⊔ x)"
using ascending_chain_def sup_left_isotone by auto
lemma descending_chain_left_add:
"descending_chain f ⟹ descending_chain (λn . x ⊔ f n)"
using descending_chain_def sup_right_isotone by blast
lemma descending_chain_right_add:
"descending_chain f ⟹ descending_chain (λn . f n ⊔ x)"
using descending_chain_def sup_left_isotone by auto
primrec pSum0 :: "(nat ⇒ 'a) ⇒ nat ⇒ 'a"
where "pSum0 f 0 = f 0"
| "pSum0 f (Suc m) = pSum0 f m ⊔ f m"
lemma pSum0_below:
"∀i . f i ≤ x ⟹ pSum0 f m ≤ x"
apply (induct m)
by auto
end
context non_associative_left_semiring
begin
lemma ascending_chain_left_mult:
"ascending_chain f ⟹ ascending_chain (λn . x * f n)"
by (simp add: mult_right_isotone ord.ascending_chain_def)
lemma ascending_chain_right_mult:
"ascending_chain f ⟹ ascending_chain (λn . f n * x)"
by (simp add: mult_left_isotone ord.ascending_chain_def)
lemma descending_chain_left_mult:
"descending_chain f ⟹ descending_chain (λn . x * f n)"
by (simp add: descending_chain_def mult_right_isotone)
lemma descending_chain_right_mult:
"descending_chain f ⟹ descending_chain (λn . f n * x)"
by (simp add: descending_chain_def mult_left_isotone)
end
context complete_lattice
begin
lemma sup_Sup:
"A ≠ {} ⟹ sup x (Sup A) = Sup ((sup x) ` A)"
apply (rule order.antisym)
apply (meson ex_in_conv imageI SUP_upper2 Sup_mono sup.boundedI sup_left_divisibility sup_right_divisibility)
by (meson SUP_least Sup_upper sup_right_isotone)
lemma sup_SUP:
"Y ≠ {} ⟹ sup x (SUP y∈Y . f y) = (SUP y∈Y. sup x (f y))"
apply (subst sup_Sup)
by (simp_all add: image_image)
lemma inf_Inf:
"A ≠ {} ⟹ inf x (Inf A) = Inf ((inf x) ` A)"
apply (rule order.antisym)
apply (meson INF_greatest Inf_lower inf.sup_right_isotone)
by (simp add: INF_inf_const1)
lemma inf_INF:
"Y ≠ {} ⟹ inf x (INF y∈Y . f y) = (INF y∈Y. inf x (f y))"
apply (subst inf_Inf)
by (simp_all add: image_image)
lemma SUP_image_id[simp]:
"(SUP x∈f`A . x) = (SUP x∈A . f x)"
by simp
lemma INF_image_id[simp]:
"(INF x∈f`A . x) = (INF x∈A . f x)"
by simp
end
lemma image_Collect_2:
"f ` { g x | x . P x } = { f (g x) | x . P x }"
by auto
text ‹The following instantiation and four lemmas are from Jose Divason Mallagaray.›
instantiation "fun" :: (type, type) power
begin
definition one_fun :: "'a ⇒ 'a"
where one_fun_def: "one_fun ≡ id"
definition times_fun :: "('a ⇒ 'a) ⇒ ('a ⇒ 'a) ⇒ ('a ⇒ 'a)"
where times_fun_def: "times_fun ≡ comp"
instance
by intro_classes
end
lemma id_power:
"id^m = id"
apply (induct m)
apply (simp add: one_fun_def)
by (simp add: times_fun_def)
lemma power_zero_id:
"f^0 = id"
by (simp add: one_fun_def)
lemma power_succ_unfold:
"f^Suc m = f ∘ f^m"
by (simp add: times_fun_def)
lemma power_succ_unfold_ext:
"(f^Suc m) x = f ((f^m) x)"
by (simp add: times_fun_def)
end
Theory Omega_Algebras
section ‹Omega Algebras›
theory Omega_Algebras
imports Stone_Kleene_Relation_Algebras.Kleene_Algebras
begin
class omega =
fixes omega :: "'a ⇒ 'a" ("_⇧ω" [100] 100)
class left_omega_algebra = left_kleene_algebra + omega +
assumes omega_unfold: "y⇧ω = y * y⇧ω"
assumes omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧ω ⊔ y⇧⋆ * z"
begin
text ‹Many lemmas in this class are taken from Georg Struth's Isabelle theories.›
lemma star_bot_below_omega:
"x⇧⋆ * bot ≤ x⇧ω"
using omega_unfold star_left_induct_equal by auto
lemma star_bot_below_omega_bot:
"x⇧⋆ * bot ≤ x⇧ω * bot"
by (metis omega_unfold star_left_induct_equal sup_monoid.add_0_left mult_assoc)
lemma omega_induct_mult:
"y ≤ x * y ⟹ y ≤ x⇧ω"
by (metis bot_least omega_induct sup.absorb1 sup.absorb2 star_bot_below_omega)
lemma omega_sub_dist:
"x⇧ω ≤ (x ⊔ y)⇧ω"
by (metis eq_refl mult_isotone omega_unfold sup.cobounded1 omega_induct_mult)
lemma omega_isotone:
"x ≤ y ⟹ x⇧ω ≤ y⇧ω"
using sup_left_divisibility omega_sub_dist by fastforce
lemma omega_induct_equal:
"y = z ⊔ x * y ⟹ y ≤ x⇧ω ⊔ x⇧⋆ * z"
by (simp add: omega_induct)
lemma omega_bot:
"bot⇧ω = bot"
by (metis mult_left_zero omega_unfold)
lemma omega_one_greatest:
"x ≤ 1⇧ω"
by (simp add: omega_induct_mult)
lemma star_mult_omega:
"x⇧⋆ * x⇧ω = x⇧ω"
by (metis order.antisym omega_unfold star.circ_loop_fixpoint star_left_induct_mult_equal sup.cobounded2)
lemma omega_sub_vector:
"x⇧ω * y ≤ x⇧ω"
by (metis mult_semi_associative omega_unfold omega_induct_mult)
lemma omega_simulation:
"z * x ≤ y * z ⟹ z * x⇧ω ≤ y⇧ω"
by (smt (verit, ccfv_threshold) mult_isotone omega_unfold order_lesseq_imp mult_assoc omega_induct_mult)
lemma omega_omega:
"x⇧ω⇧ω ≤ x⇧ω"
by (metis omega_unfold omega_sub_vector)
lemma left_plus_omega:
"(x * x⇧⋆)⇧ω = x⇧ω"
by (metis order.antisym mult_assoc omega_induct_mult omega_unfold order_refl star.left_plus_circ star_mult_omega)
lemma omega_slide:
"x * (y * x)⇧ω = (x * y)⇧ω"
by (metis order.antisym mult_assoc mult_right_isotone omega_simulation omega_unfold order_refl)
lemma omega_simulation_2:
"y * x ≤ x * y ⟹ (x * y)⇧ω ≤ x⇧ω"
by (metis mult_right_isotone sup.absorb2 omega_induct_mult omega_slide omega_sub_dist)
lemma wagner:
"(x ⊔ y)⇧ω = x * (x ⊔ y)⇧ω ⊔ z ⟹ (x ⊔ y)⇧ω = x⇧ω ⊔ x⇧⋆ * z"
by (smt (verit, ccfv_SIG) order.refl star_left_induct sup.absorb2 sup_assoc sup_commute omega_induct_equal omega_sub_dist)
lemma right_plus_omega:
"(x⇧⋆ * x)⇧ω = x⇧ω"
by (metis left_plus_omega omega_slide star_mult_omega)
lemma omega_sub_dist_1:
"(x * y⇧⋆)⇧ω ≤ (x ⊔ y)⇧ω"
by (metis left_plus_omega mult_isotone star.circ_sub_dist sup.cobounded1 sup_monoid.add_commute omega_isotone)
lemma omega_sub_dist_2:
"(x⇧⋆ * y)⇧ω ≤ (x ⊔ y)⇧ω"
by (metis mult_isotone star.circ_sub_dist sup.cobounded2 omega_isotone right_plus_omega)
lemma omega_star:
"(x⇧ω)⇧⋆ = 1 ⊔ x⇧ω"
by (metis antisym_conv star.circ_mult_increasing star_left_unfold_equal omega_sub_vector)
lemma omega_mult_omega_star:
"x⇧ω * x⇧ω⇧⋆ = x⇧ω"
by (simp add: order.antisym star.circ_mult_increasing omega_sub_vector)
lemma omega_sum_unfold_1:
"(x ⊔ y)⇧ω = x⇧ω ⊔ x⇧⋆ * y * (x ⊔ y)⇧ω"
by (metis mult_right_dist_sup omega_unfold mult_assoc wagner)
lemma omega_sum_unfold_2:
"(x ⊔ y)⇧ω ≤ (x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * x⇧ω"
using omega_induct_equal omega_sum_unfold_1 by auto
lemma omega_sum_unfold_3:
"(x⇧⋆ * y)⇧⋆ * x⇧ω ≤ (x ⊔ y)⇧ω"
using star_left_induct_equal omega_sum_unfold_1 by auto
lemma omega_decompose:
"(x ⊔ y)⇧ω = (x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * x⇧ω"
by (metis sup.absorb1 sup_same_context omega_sub_dist_2 omega_sum_unfold_2 omega_sum_unfold_3)
lemma omega_loop_fixpoint:
"y * (y⇧ω ⊔ y⇧⋆ * z) ⊔ z = y⇧ω ⊔ y⇧⋆ * z"
apply (rule order.antisym)
apply (smt (verit, ccfv_threshold) eq_refl mult_isotone mult_left_sub_dist_sup omega_induct omega_unfold star.circ_loop_fixpoint sup_assoc sup_commute sup_right_isotone)
by (smt (z3) mult_left_sub_dist_sup omega_unfold star.circ_loop_fixpoint sup.left_commute sup_commute sup_right_isotone)
lemma omega_loop_greatest_fixpoint:
"y * x ⊔ z = x ⟹ x ≤ y⇧ω ⊔ y⇧⋆ * z"
by (simp add: sup_commute omega_induct_equal)
lemma omega_square:
"x⇧ω = (x * x)⇧ω"
using order.antisym omega_unfold order_refl mult_assoc omega_induct_mult omega_simulation_2 by auto
lemma mult_bot_omega:
"(x * bot)⇧ω = x * bot"
by (metis mult_left_zero omega_slide)
lemma mult_bot_add_omega:
"(x ⊔ y * bot)⇧ω = x⇧ω ⊔ x⇧⋆ * y * bot"
by (metis mult_left_zero sup_commute mult_assoc mult_bot_omega omega_decompose omega_loop_fixpoint)
lemma omega_mult_star:
"x⇧ω * x⇧⋆ = x⇧ω"
by (meson antisym_conv star.circ_back_loop_prefixpoint sup.boundedE omega_sub_vector)
lemma omega_loop_is_greatest_fixpoint:
"is_greatest_fixpoint (λx . y * x ⊔ z) (y⇧ω ⊔ y⇧⋆ * z)"
by (simp add: is_greatest_fixpoint_def omega_loop_fixpoint omega_loop_greatest_fixpoint)
lemma omega_loop_nu:
"ν (λx . y * x ⊔ z) = y⇧ω ⊔ y⇧⋆ * z"
by (metis greatest_fixpoint_same omega_loop_is_greatest_fixpoint)
lemma omega_loop_bot_is_greatest_fixpoint:
"is_greatest_fixpoint (λx . y * x) (y⇧ω)"
using is_greatest_fixpoint_def omega_unfold omega_induct_mult by auto
lemma omega_loop_bot_nu:
"ν (λx . y * x) = y⇧ω"
by (metis greatest_fixpoint_same omega_loop_bot_is_greatest_fixpoint)
lemma affine_has_greatest_fixpoint:
"has_greatest_fixpoint (λx . y * x ⊔ z)"
using has_greatest_fixpoint_def omega_loop_is_greatest_fixpoint by blast
lemma omega_separate_unfold:
"(x⇧⋆ * y)⇧ω = y⇧ω ⊔ y⇧⋆ * x * (x⇧⋆ * y)⇧ω"
by (metis star.circ_loop_fixpoint sup_commute mult_assoc omega_slide omega_sum_unfold_1)
lemma omega_bot_left_slide:
"(x * y)⇧⋆ * ((x * y)⇧ω * bot ⊔ 1) * x ≤ x * (y * x)⇧⋆ * ((y * x)⇧ω * bot ⊔ 1)"
proof -
have "x ⊔ x * (y * x) * (y * x)⇧⋆ * ((y * x)⇧ω * bot ⊔ 1) ≤ x * (y * x)⇧⋆ * ((y * x)⇧ω * bot ⊔ 1)"
by (metis sup_commute mult_assoc mult_right_isotone star.circ_back_loop_prefixpoint star.mult_zero_sup_circ star.mult_zero_circ le_supE le_supI order.refl star.circ_increasing star.circ_mult_upper_bound)
hence "((x * y)⇧ω * bot ⊔ 1) * x ⊔ x * y * (x * (y * x)⇧⋆ * ((y * x)⇧ω * bot ⊔ 1)) ≤ x * (y * x)⇧⋆ * ((y * x)⇧ω * bot ⊔ 1)"
by (smt (z3) sup.absorb_iff2 sup_assoc mult_assoc mult_left_one mult_left_sub_dist_sup_left mult_left_zero mult_right_dist_sup omega_slide star_mult_omega)
thus ?thesis
by (simp add: star_left_induct mult_assoc)
qed
lemma omega_bot_add_1:
"(x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1) = x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
proof (rule order.antisym)
have 1: "(x ⊔ y) * x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1) ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
by (smt (z3) eq_refl star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_sup_1 sup_assoc sup_commute mult_assoc)
have 2: "1 ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
using reflexive_mult_closed star.circ_reflexive sup_ge2 by auto
have "(y * x⇧⋆)⇧ω * bot ≤ (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot"
by (metis mult_1_right mult_left_isotone mult_left_sub_dist_sup_right omega_isotone)
also have 3: "... ≤ (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
by (metis mult_isotone mult_left_one star.circ_reflexive sup_commute sup_ge2)
finally have 4: "(x⇧⋆ * y)⇧ω * bot ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
by (smt mult_assoc mult_right_isotone omega_slide)
have "y * (x⇧⋆ * y)⇧⋆ * x⇧ω * bot ≤ y * (x⇧⋆ * (x⇧ω * bot ⊔ y))⇧⋆ * x⇧⋆ * x⇧ω * bot * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot"
using mult_isotone mult_left_sub_dist_sup_left mult_left_zero order.refl star_isotone sup_commute mult_assoc star_mult_omega by auto
also have "... ≤ y * (x⇧⋆ * (x⇧ω * bot ⊔ y))⇧⋆ * (x⇧⋆ * (x⇧ω * bot ⊔ 1) * y)⇧ω * bot"
by (smt mult_assoc mult_left_isotone mult_left_sub_dist_sup_left omega_slide)
also have "... = y * (x⇧⋆ * (x⇧ω * bot ⊔ 1) * y)⇧ω * bot"
using mult_left_one mult_left_zero mult_right_dist_sup mult_assoc star_mult_omega by auto
finally have "x⇧⋆ * y * (x⇧⋆ * y)⇧⋆ * x⇧ω * bot ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
using 3 by (smt mult_assoc mult_right_isotone omega_slide order_trans)
hence "(x⇧⋆ * y)⇧⋆ * x⇧ω * bot ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
by (smt (verit, ccfv_threshold) sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_one mult_1_right mult_right_sub_dist_sup_left order_trans star.circ_loop_fixpoint star.circ_reflexive star.mult_zero_circ)
hence "(x ⊔ y)⇧ω * bot ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
using 4 by (smt (z3) mult_right_dist_sup sup.orderE sup_assoc sup_right_divisibility omega_decompose)
thus "(x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1) ≤ x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1)"
using 1 2 star_left_induct mult_assoc by force
next
have 5: "x⇧ω * bot ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
by (metis bot_least le_supI1 le_supI2 mult_isotone star.circ_loop_fixpoint sup.cobounded1 omega_isotone)
have 6: "(y * x⇧⋆)⇧ω * bot ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
by (metis sup_commute mult_left_isotone omega_sub_dist_1 mult_assoc mult_left_sub_dist_sup_left order_trans star_mult_omega)
have 7: "(y * x⇧⋆)⇧⋆ ≤ (x ⊔ y)⇧⋆"
by (metis mult_left_one mult_right_sub_dist_sup_left star.circ_sup_1 star.circ_plus_one)
hence "(y * x⇧⋆)⇧⋆ * x⇧ω * bot ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
by (smt sup_assoc le_iff_sup mult_assoc mult_isotone mult_right_dist_sup omega_sub_dist)
hence "(x⇧ω * bot ⊔ y * x⇧⋆)⇧ω * bot ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
using 6 by (smt sup_commute sup.bounded_iff mult_assoc mult_right_dist_sup mult_bot_add_omega omega_unfold omega_bot)
hence "(y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ≤ y * x⇧⋆ * (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
by (smt mult_assoc mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone omega_slide)
also have "... ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
using 7 by (metis mult_left_isotone order_refl star.circ_mult_upper_bound star_left_induct_mult_iff)
finally have "(y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1) ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
using 5 by (smt (z3) le_supE star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_involutive star_isotone sup_commute)
hence "(x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1) ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
using 5 by (metis sup_commute mult_assoc star.circ_isotone star.circ_mult_upper_bound star.mult_zero_sup_circ star.mult_zero_circ star_involutive)
thus "x⇧⋆ * (x⇧ω * bot ⊔ 1) * (y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧⋆ * ((y * x⇧⋆ * (x⇧ω * bot ⊔ 1))⇧ω * bot ⊔ 1) ≤ (x ⊔ y)⇧⋆ * ((x ⊔ y)⇧ω * bot ⊔ 1)"
by (smt sup_assoc sup_commute mult_assoc star.circ_mult_upper_bound star.circ_sub_dist star.mult_zero_sup_circ star.mult_zero_circ)
qed
lemma star_omega_greatest:
"x⇧⋆⇧ω = 1⇧ω"
by (metis sup_commute le_iff_sup omega_one_greatest omega_sub_dist star.circ_plus_one)
lemma omega_vector_greatest:
"x⇧ω * 1⇧ω = x⇧ω"
by (metis order.antisym mult_isotone omega_mult_omega_star omega_one_greatest omega_sub_vector)
lemma mult_greatest_omega:
"(x * 1⇧ω)⇧ω ≤ x * 1⇧ω"
by (metis mult_right_isotone omega_slide omega_sub_vector)
lemma omega_mult_star_2:
"x⇧ω * y⇧⋆ = x⇧ω"
by (meson order.antisym le_supE star.circ_back_loop_prefixpoint omega_sub_vector)
lemma omega_import:
assumes "p ≤ p * p"
and "p * x ≤ x * p"
shows "p * x⇧ω = p * (p * x)⇧ω"
proof -
have "p * x⇧ω ≤ p * (p * x) * x⇧ω"
by (metis assms(1) mult_assoc mult_left_isotone omega_unfold)
also have "... ≤ p * x * p * x⇧ω"
by (metis assms(2) mult_assoc mult_left_isotone mult_right_isotone)
finally have "p * x⇧ω ≤ (p * x)⇧ω"
by (simp add: mult_assoc omega_induct_mult)
hence "p * x⇧ω ≤ p * (p * x)⇧ω"
by (metis assms(1) mult_assoc mult_left_isotone mult_right_isotone order_trans)
thus "p * x⇧ω = p * (p * x)⇧ω"
by (metis assms(2) sup_left_divisibility order.antisym mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)
qed
end
text ‹Theorem 50.2›
sublocale left_omega_algebra < comb0: left_conway_semiring where circ = "(λx . x⇧⋆ * (x⇧ω * bot ⊔ 1))"
apply unfold_locales
apply (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_sub_dist_sup_left omega_unfold star.circ_loop_fixpoint star_mult_omega)
using omega_bot_left_slide mult_assoc apply fastforce
using omega_bot_add_1 mult_assoc by simp
class left_zero_omega_algebra = left_zero_kleene_algebra + left_omega_algebra
begin
lemma star_omega_absorb:
"y⇧⋆ * (y⇧⋆ * x)⇧⋆ * y⇧ω = (y⇧⋆ * x)⇧⋆ * y⇧ω"
proof -
have "y⇧⋆ * (y⇧⋆ * x)⇧⋆ * y⇧ω = y⇧⋆ * y⇧⋆ * x * (y⇧⋆ * x)⇧⋆ * y⇧ω ⊔ y⇧⋆ * y⇧ω"
by (metis sup_commute mult_assoc mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same)
thus ?thesis
by (metis mult_assoc star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
qed
lemma omega_circ_simulate_right_plus:
assumes "z * x ≤ y * (y⇧ω * bot ⊔ y⇧⋆) * z ⊔ w"
shows "z * (x⇧ω * bot ⊔ x⇧⋆) ≤ (y⇧ω * bot ⊔ y⇧⋆) * (z ⊔ w * (x⇧ω * bot ⊔ x⇧⋆))"
proof -
have 1: "z * x ≤ y⇧ω * bot ⊔ y * y⇧⋆ * z ⊔ w"
by (metis assms mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold)
hence "(y⇧ω * bot ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆) * x ≤ y⇧ω * bot ⊔ y⇧⋆ * (y⇧ω * bot ⊔ y * y⇧⋆ * z ⊔ w) ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆"
by (smt sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup star.circ_back_loop_fixpoint)
also have "... = y⇧ω * bot ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆"
by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_back_loop_fixpoint star_mult_omega)
also have "... ≤ y⇧ω * bot ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆"
by (smt sup_commute sup_left_isotone mult_left_isotone star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
finally have "z ⊔ (y⇧ω * bot ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆) * x ≤ y⇧ω * bot ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆"
by (metis (no_types, lifting) le_supE le_supI star.circ_loop_fixpoint sup.cobounded1)
hence 2: "z * x⇧⋆ ≤ y⇧ω * bot ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧ω * bot ⊔ y⇧⋆ * w * x⇧⋆"
by (simp add: star_right_induct)
have "z * x⇧ω * bot ≤ (y⇧ω * bot ⊔ y * y⇧⋆ * z ⊔ w) * x⇧ω * bot"
using 1 by (smt sup_left_divisibility mult_assoc mult_right_sub_dist_sup_left omega_unfold)
hence "z * x⇧ω * bot ≤ y⇧ω ⊔ y⇧⋆ * (y⇧ω * bot ⊔ w * x⇧ω * bot)"
by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_zero mult_right_dist_sup omega_induct star.left_plus_circ)
thus "z * (x⇧ω * bot ⊔ x⇧⋆) ≤ (y⇧ω * bot ⊔ y⇧⋆) * (z ⊔ w * (x⇧ω * bot ⊔ x⇧⋆))"
using 2 by (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold omega_bot star_mult_omega zero_right_mult_decreasing)
qed
lemma omega_circ_simulate_left_plus:
assumes "x * z ≤ z * (y⇧ω * bot ⊔ y⇧⋆) ⊔ w"
shows "(x⇧ω * bot ⊔ x⇧⋆) * z ≤ (z ⊔ (x⇧ω * bot ⊔ x⇧⋆) * w) * (y⇧ω * bot ⊔ y⇧⋆)"
proof -
have "x * (z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆) = x * z * y⇧ω * bot ⊔ x * z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x * x⇧⋆ * w * y⇧ω * bot ⊔ x * x⇧⋆ * w * y⇧⋆"
by (smt mult_assoc mult_left_dist_sup omega_unfold)
also have "... ≤ x * z * y⇧ω * bot ⊔ x * z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (metis sup_mono sup_right_isotone mult_left_isotone star.left_plus_below_circ)
also have "... ≤ (z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ w) * y⇧ω * bot ⊔ (z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ w) * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (metis assms sup_left_isotone mult_assoc mult_left_dist_sup mult_left_isotone)
also have "... = z * y⇧ω * bot ⊔ z * y⇧⋆ * y⇧ω * bot ⊔ w * y⇧ω * bot ⊔ z * y⇧ω * bot ⊔ z * y⇧⋆ * y⇧⋆ ⊔ w * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc mult_assoc mult_left_zero mult_right_dist_sup)
also have "... = z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (smt (verit, ccfv_threshold) sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
finally have "x⇧⋆ * z ≤ z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (smt (z3) le_supE sup_least sup_ge1 star.circ_back_loop_fixpoint star_left_induct)
hence "(x⇧ω * bot ⊔ x⇧⋆) * z ≤ z * y⇧ω * bot ⊔ z * y⇧⋆ ⊔ x⇧ω * bot ⊔ x⇧⋆ * w * y⇧ω * bot ⊔ x⇧⋆ * w * y⇧⋆"
by (smt (z3) sup.left_commute sup_commute sup_least sup_ge1 mult_assoc mult_left_zero mult_right_dist_sup)
thus "(x⇧ω * bot ⊔ x⇧⋆) * z ≤ (z ⊔ (x⇧ω * bot ⊔ x⇧⋆) * w) * (y⇧ω * bot ⊔ y⇧⋆)"
by (smt sup_assoc mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup)
qed
lemma omega_translate:
"x⇧⋆ * (x⇧ω * bot ⊔ 1) = x⇧ω * bot ⊔ x⇧⋆"
by (metis mult_assoc mult_left_dist_sup mult_1_right star_mult_omega)
lemma omega_circ_simulate_right:
assumes "z * x ≤ y * z ⊔ w"
shows "z * (x⇧ω * bot ⊔ x⇧⋆) ≤ (y⇧ω * bot ⊔ y⇧⋆) * (z ⊔ w * (x⇧ω * bot ⊔ x⇧⋆))"
proof -
have "... ≤ y * (y⇧ω * bot ⊔ y⇧⋆) * z ⊔ w"
using comb0.circ_mult_increasing mult_isotone sup_left_isotone omega_translate by auto
thus "z * (x⇧ω * bot ⊔ x⇧⋆) ≤ (y⇧ω * bot ⊔ y⇧⋆) * (z ⊔ w * (x⇧ω * bot ⊔ x⇧⋆))"
using assms order_trans omega_circ_simulate_right_plus by blast
qed
end
sublocale left_zero_omega_algebra < comb1: left_conway_semiring_1 where circ = "(λx . x⇧⋆ * (x⇧ω * bot ⊔ 1))"
apply unfold_locales
by (smt order.eq_iff mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup mult_1_right omega_slide star_slide)
sublocale left_zero_omega_algebra < comb0: itering where circ = "(λx . x⇧⋆ * (x⇧ω * bot ⊔ 1))"
apply unfold_locales
using comb1.circ_sup_9 apply blast
using comb1.circ_mult_1 apply blast
apply (metis omega_circ_simulate_right_plus omega_translate)
using omega_circ_simulate_left_plus omega_translate by auto
text ‹Theorem 2.2›
sublocale left_zero_omega_algebra < comb2: itering where circ = "(λx . x⇧ω * bot ⊔ x⇧⋆)"
apply unfold_locales
using comb1.circ_sup_9 omega_translate apply force
apply (metis comb1.circ_mult_1 omega_translate)
using omega_circ_simulate_right_plus apply blast
by (simp add: omega_circ_simulate_left_plus)
class omega_algebra = kleene_algebra + left_zero_omega_algebra
class left_omega_conway_semiring = left_omega_algebra + left_conway_semiring
begin
subclass left_kleene_conway_semiring ..
lemma circ_below_omega_star:
"x⇧∘ ≤ x⇧ω ⊔ x⇧⋆"
by (metis circ_left_unfold mult_1_right omega_induct order_refl)
lemma omega_mult_circ:
"x⇧ω * x⇧∘ = x⇧ω"
by (metis circ_star omega_mult_star_2)
lemma circ_mult_omega:
"x⇧∘ * x⇧ω = x⇧ω"
by (metis order.antisym sup_right_divisibility circ_loop_fixpoint circ_plus_sub omega_simulation)
lemma circ_omega_greatest:
"x⇧∘⇧ω = 1⇧ω"
by (metis circ_star star_omega_greatest)
lemma omega_circ:
"x⇧ω⇧∘ = 1 ⊔ x⇧ω"
by (metis order.antisym circ_left_unfold mult_left_sub_dist_sup_left mult_1_right omega_sub_vector)
end
class bounded_left_omega_algebra = bounded_left_kleene_algebra + left_omega_algebra
begin
lemma omega_one:
"1⇧ω = top"
by (simp add: order.antisym omega_one_greatest)
lemma star_omega_top:
"x⇧⋆⇧ω = top"
by (simp add: star_omega_greatest omega_one)
lemma omega_vector:
"x⇧ω * top = x⇧ω"
by (simp add: order.antisym omega_sub_vector top_right_mult_increasing)
lemma mult_top_omega:
"(x * top)⇧ω ≤ x * top"
using mult_greatest_omega omega_one by auto
end
sublocale bounded_left_omega_algebra < comb0: bounded_left_conway_semiring where circ = "(λx . x⇧⋆ * (x⇧ω * bot ⊔ 1))" ..
class bounded_left_zero_omega_algebra = bounded_left_zero_kleene_algebra + left_zero_omega_algebra
begin
subclass bounded_left_omega_algebra ..
end
sublocale bounded_left_zero_omega_algebra < comb0: bounded_itering where circ = "(λx . x⇧⋆ * (x⇧ω * bot ⊔ 1))" ..
class bounded_omega_algebra = bounded_kleene_algebra + omega_algebra
begin
subclass bounded_left_zero_omega_algebra ..
end
class bounded_left_omega_conway_semiring = bounded_left_omega_algebra + left_omega_conway_semiring
begin
subclass left_kleene_conway_semiring ..
subclass bounded_left_conway_semiring ..
lemma circ_omega:
"x⇧∘⇧ω = top"
by (simp add: circ_omega_greatest omega_one)
end
class top_left_omega_algebra = bounded_left_omega_algebra +
assumes top_left_bot: "top * x = top"
begin
lemma omega_translate_3:
"x⇧⋆ * (x⇧ω * bot ⊔ 1) = x⇧⋆ * (x⇧ω ⊔ 1)"
by (metis omega_one omega_vector_greatest top_left_bot mult_assoc)
end
text ‹Theorem 50.2›
sublocale top_left_omega_algebra < comb4: left_conway_semiring where circ = "(λx . x⇧⋆ * (x⇧ω ⊔ 1))"
apply unfold_locales
using comb0.circ_left_unfold omega_translate_3 apply force
using omega_bot_left_slide omega_translate_3 mult_assoc apply force
using comb0.circ_sup_1 omega_translate_3 by auto
class top_left_bot_omega_algebra = bounded_left_zero_omega_algebra +
assumes top_left_bot: "top * x = top"
begin
lemma omega_translate_2:
"x⇧ω * bot ⊔ x⇧⋆ = x⇧ω ⊔ x⇧⋆"
by (metis mult_assoc omega_mult_star_2 star.circ_top top_left_bot)
end
text ‹Theorem 2.3›
sublocale top_left_bot_omega_algebra < comb3: itering where circ = "(λx . x⇧ω ⊔ x⇧⋆)"
apply unfold_locales
using comb2.circ_slide_1 comb2.circ_sup_1 omega_translate_2 apply force
apply (metis comb2.circ_mult_1 omega_translate_2)
using omega_circ_simulate_right_plus omega_translate_2 apply force
using omega_circ_simulate_left_plus omega_translate_2 by auto
class Omega =
fixes Omega :: "'a ⇒ 'a" ("_⇧Ω" [100] 100)
end
Theory Capped_Omega_Algebras
section ‹Capped Omega Algebras›
theory Capped_Omega_Algebras
imports Omega_Algebras
begin
class capped_omega =
fixes capped_omega :: "'a ⇒ 'a ⇒ 'a" ("_⇧ω⇩_" [100,100] 100)
class capped_omega_algebra = bounded_left_zero_kleene_algebra + bounded_distrib_lattice + capped_omega +
assumes capped_omega_unfold: "y⇧ω⇩v = y * y⇧ω⇩v ⊓ v"
assumes capped_omega_induct: "x ≤ (y * x ⊔ z) ⊓ v ⟶ x ≤ y⇧ω⇩v ⊔ y⇧⋆ * z"
text ‹AACP Theorem 6.1›
notation
top ("⊤")
sublocale capped_omega_algebra < capped: bounded_left_zero_omega_algebra where omega = "(λy . y⇧ω⇩⊤)"
apply unfold_locales
apply (metis capped_omega_unfold inf_top_right)
by (simp add: capped_omega_induct sup_commute)
context capped_omega_algebra
begin
text ‹AACP Theorem 6.2›
lemma capped_omega_below_omega:
"y⇧ω⇩v ≤ y⇧ω⇩⊤"
using capped.omega_induct_mult capped_omega_unfold order.eq_iff by force
text ‹AACP Theorem 6.3›
lemma capped_omega_below:
"y⇧ω⇩v ≤ v"
using capped_omega_unfold order.eq_iff by force
text ‹AACP Theorem 6.4›
lemma capped_omega_one:
"1⇧ω⇩v = v"
proof -
have "v ≤ (1 * v ⊔ bot) ⊓ v"
by simp
hence "v ≤ 1⇧ω⇩v ⊔ 1⇧⋆ * bot"
by (simp add: capped_omega_induct)
also have "... = 1⇧ω⇩v"
by (simp add: star_one)
finally show ?thesis
by (simp add: capped_omega_below order.antisym)
qed
text ‹AACP Theorem 6.5›
lemma capped_omega_zero:
"bot⇧ω⇩v = bot"
by (metis capped_omega_below_omega bot_unique capped.omega_bot)
lemma star_below_cap:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ y⇧⋆ * z ≤ v"
by (metis le_sup_iff order.trans mult_left_isotone star_left_induct)
lemma capped_fix:
assumes "y ≤ u"
and "z ≤ v"
and "u * v ≤ v"
shows "(y * (y⇧ω⇩v ⊔ y⇧⋆ * z) ⊔ z) ⊓ v = y⇧ω⇩v ⊔ y⇧⋆ * z"
proof -
have "(y * (y⇧ω⇩v ⊔ y⇧⋆ * z) ⊔ z) ⊓ v = (y * y⇧ω⇩v ⊔ y⇧⋆ * z) ⊓ v"
by (simp add: mult_left_dist_sup star.circ_loop_fixpoint sup_assoc)
also have "... = (y * y⇧ω⇩v ⊓ v) ⊔ (y⇧⋆ * z ⊓ v)"
by (simp add: inf_sup_distrib2)
also have "... = y⇧ω⇩v ⊔ y⇧⋆ * z"
using assms capped_omega_unfold le_iff_inf star_below_cap by auto
finally show ?thesis
.
qed
lemma capped_fixpoint:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_fixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧ω⇩v ⊔ y⇧⋆ * z)"
by (simp add: capped_fix is_fixpoint_def)
lemma capped_greatest_fixpoint:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_greatest_fixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧ω⇩v ⊔ y⇧⋆ * z)"
by (smt capped_fix order_refl capped_omega_induct is_greatest_fixpoint_def)
lemma capped_postfixpoint:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_postfixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧ω⇩v ⊔ y⇧⋆ * z)"
using capped_fix inf.eq_refl is_postfixpoint_def by auto
lemma capped_greatest_postfixpoint:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_greatest_postfixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧ω⇩v ⊔ y⇧⋆ * z)"
by (smt capped_fix order_refl capped_omega_induct is_greatest_postfixpoint_def)
text ‹AACP Theorem 6.6›
lemma capped_nu:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ ν(λx . (y * x ⊔ z) ⊓ v) = y⇧ω⇩v ⊔ y⇧⋆ * z"
by (metis capped_greatest_fixpoint greatest_fixpoint_same)
lemma capped_pnu:
"y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ pν(λx . (y * x ⊔ z) ⊓ v) = y⇧ω⇩v ⊔ y⇧⋆ * z"
by (metis capped_greatest_postfixpoint greatest_postfixpoint_same)
text ‹AACP Theorem 6.7›
lemma unfold_capped_omega:
"y ≤ u ⟹ u * v ≤ v ⟹ y * y⇧ω⇩v = y⇧ω⇩v"
by (smt (verit, ccfv_SIG) capped_omega_below capped_omega_unfold inf.order_lesseq_imp le_iff_inf mult_isotone)
text ‹AACP Theorem 6.8›
lemma star_mult_capped_omega:
assumes "y ≤ u"
and "u * v ≤ v"
shows "y⇧⋆ * y⇧ω⇩v = y⇧ω⇩v"
proof -
have "y * y⇧ω⇩v = y⇧ω⇩v"
using assms unfold_capped_omega by auto
hence "y⇧⋆ * y⇧ω⇩v ≤ y⇧ω⇩v"
by (simp add: star_left_induct_mult)
thus ?thesis
by (metis sup_ge2 order.antisym star.circ_loop_fixpoint)
qed
text ‹AACP Theorem 6.9›
lemma star_zero_below_capped_omega_zero:
assumes "y ≤ u"
and "u * v ≤ v"
shows "y⇧⋆ * bot ≤ y⇧ω⇩v * bot"
proof -
have "y * y⇧ω⇩v ≤ v"
using assms capped_omega_below unfold_capped_omega by auto
hence "y * y⇧ω⇩v = y⇧ω⇩v"
using assms unfold_capped_omega by auto
thus ?thesis
by (metis bot_least eq_refl mult_assoc star_below_cap)
qed
lemma star_zero_below_capped_omega:
"y ≤ u ⟹ u * v ≤ v ⟹ y⇧⋆ * bot ≤ y⇧ω⇩v"
by (simp add: star_loop_least_fixpoint unfold_capped_omega)
lemma capped_omega_induct_meet_zero:
"x ≤ y * x ⊓ v ⟹ x ≤ y⇧ω⇩v ⊔ y⇧⋆ * bot"
by (simp add: capped_omega_induct)
text ‹AACP Theorem 6.10›
lemma capped_omega_induct_meet:
"y ≤ u ⟹ u * v ≤ v ⟹ x ≤ y * x ⊓ v ⟹ x ≤ y⇧ω⇩v"
by (metis capped_omega_induct_meet_zero sup_commute le_iff_sup star_zero_below_capped_omega)
lemma capped_omega_induct_equal:
"x = (y * x ⊔ z) ⊓ v ⟹ x ≤ y⇧ω⇩v ⊔ y⇧⋆ * z"
using capped_omega_induct inf.le_iff_sup by auto
text ‹AACP Theorem 6.11›
lemma capped_meet_nu:
assumes "y ≤ u"
and "u * v ≤ v"
shows "ν(λx . y * x ⊓ v) = y⇧ω⇩v"
proof -
have "y⇧ω⇩v ⊔ y⇧⋆ * bot = y⇧ω⇩v"
by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
hence "ν(λx . (y * x ⊔ bot) ⊓ v) = y⇧ω⇩v"
by (metis assms capped_nu bot_least)
thus ?thesis
by simp
qed
lemma capped_meet_pnu:
assumes "y ≤ u"
and "u * v ≤ v"
shows "pν(λx . y * x ⊓ v) = y⇧ω⇩v"
proof -
have "y⇧ω⇩v ⊔ y⇧⋆ * bot = y⇧ω⇩v"
by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
hence "pν(λx . (y * x ⊔ bot) ⊓ v) = y⇧ω⇩v"
by (metis assms capped_pnu bot_least)
thus ?thesis
by simp
qed
text ‹AACP Theorem 6.12›
lemma capped_omega_isotone:
"y ≤ u ⟹ u * v ≤ v ⟹ t ≤ y ⟹ t⇧ω⇩v ≤ y⇧ω⇩v"
by (metis capped_omega_induct_meet capped_omega_unfold le_iff_sup inf.sup_left_isotone mult_right_sub_dist_sup_left)
text ‹AACP Theorem 6.13›
lemma capped_omega_simulation:
assumes "y ≤ u"
and "s ≤ u"
and "u * v ≤ v"
and "s * t ≤ y * s"
shows "s * t⇧ω⇩v ≤ y⇧ω⇩v"
proof -
have "s * t⇧ω⇩v ≤ s * t * t⇧ω⇩v ⊓ s * v"
by (metis capped_omega_below capped_omega_unfold inf.boundedI inf.cobounded1 mult_right_isotone mult_assoc)
also have "... ≤ s * t * t⇧ω⇩v ⊓ v"
using assms(2,3) inf.order_lesseq_imp inf.sup_right_isotone mult_left_isotone by blast
also have "... ≤ y * s * t⇧ω⇩v ⊓ v"
using assms(4) inf.sup_left_isotone mult_left_isotone by auto
finally show ?thesis
using assms(1,3) capped_omega_induct_meet mult_assoc by auto
qed
lemma capped_omega_slide_sub:
assumes "s ≤ u"
and "y ≤ u"
and "u * u ≤ u"
and "u * v ≤ v"
shows "s * (y * s)⇧ω⇩v ≤ (s * y)⇧ω⇩v"
proof -
have "s * y ≤ u"
by (meson assms(1-3) mult_isotone order_trans)
thus ?thesis
using assms(1,4) capped_omega_simulation mult_assoc by auto
qed
text ‹AACP Theorem 6.14›
lemma capped_omega_slide:
"s ≤ u ⟹ y ≤ u ⟹ u * u ≤ u ⟹ u * v ≤ v ⟹ s * (y * s)⇧ω⇩v = (s * y)⇧ω⇩v"
by (smt (verit) order.antisym mult_assoc mult_right_isotone capped_omega_unfold capped_omega_slide_sub inf.sup_ge1 order_trans)
lemma capped_omega_sub_dist:
"s ≤ u ⟹ y ≤ u ⟹ u * v ≤ v ⟹ s⇧ω⇩v ≤ (s ⊔ y)⇧ω⇩v"
by (simp add: capped_omega_isotone)
text ‹AACP Theorem 6.15›
lemma capped_omega_simulation_2:
assumes "s ≤ u"
and "y ≤ u"
and "u * u ≤ u"
and "u * v ≤ v"
and "y * s ≤ s * y"
shows "(s * y)⇧ω⇩v ≤ s⇧ω⇩v"
proof -
have 1: "s * y ≤ u"
using assms(1-3) inf.order_lesseq_imp mult_isotone by blast
have 2: "s * (s * y)⇧ω⇩v ≤ v"
by (meson assms(1,4) capped_omega_below order.trans mult_isotone)
have "(s * y)⇧ω⇩v = s * (y * s)⇧ω⇩v"
using assms(1-4) capped_omega_slide by auto
also have "... ≤ s * (s * y)⇧ω⇩v"
using 1 assms(4,5) capped_omega_isotone mult_right_isotone by blast
also have "... = s * (s * y)⇧ω⇩v ⊓ v"
using 2 inf.order_iff by auto
finally show ?thesis
using assms(1,4) capped_omega_induct_meet by blast
qed
text ‹AACP Theorem 6.16›
lemma left_plus_capped_omega:
assumes "y ≤ u"
and "u * u ≤ u"
and "u * v ≤ v"
shows "(y * y⇧⋆)⇧ω⇩v = y⇧ω⇩v"
proof -
have 1: "y * y⇧⋆ ≤ u"
by (metis assms(1,2) star_plus star_below_cap)
hence "y * y⇧⋆ * (y * y⇧⋆)⇧ω⇩v ≤ v"
using assms(3) capped_omega_below unfold_capped_omega by auto
hence "y * y⇧⋆ * (y * y⇧⋆)⇧ω⇩v = (y * y⇧⋆)⇧ω⇩v"
using 1 assms(3) unfold_capped_omega by blast
hence "(y * y⇧⋆)⇧ω⇩v ≤ y⇧ω⇩v"
using 1 by (smt assms(1,3) capped_omega_simulation mult_assoc mult_semi_associative star.circ_transitive_equal star_simulation_right_equal)
thus ?thesis
using 1 by (meson assms(3) capped_omega_isotone order.antisym star.circ_mult_increasing)
qed
text ‹AACP Theorem 6.17›
lemma capped_omega_sub_vector:
assumes "z ≤ v"
and "y ≤ u"
and "u * v ≤ v"
shows "y⇧ω⇩u * z ≤ y⇧ω⇩v"
proof -
have "y⇧ω⇩u * z ≤ y * y⇧ω⇩u * z ⊓ u * z"
by (metis capped_omega_below capped_omega_unfold eq_refl inf.boundedI inf.cobounded1 mult_isotone)
also have "... ≤ y * y⇧ω⇩u * z ⊓ v"
by (metis assms(1,3) inf.sup_left_isotone inf_commute mult_right_isotone order_trans)
finally show ?thesis
using assms(2,3) capped_omega_induct_meet mult_assoc by auto
qed
text ‹AACP Theorem 6.18›
lemma capped_omega_omega:
"y ≤ u ⟹ u * v ≤ v ⟹ (y⇧ω⇩u)⇧ω⇩v ≤ y⇧ω⇩v"
by (metis capped_omega_below capped_omega_sub_vector unfold_capped_omega)
end
end
Theory General_Refinement_Algebras
section ‹General Refinement Algebras›
theory General_Refinement_Algebras
imports Omega_Algebras
begin
class general_refinement_algebra = left_kleene_algebra + Omega +
assumes Omega_unfold: "y⇧Ω ≤ 1 ⊔ y * y⇧Ω"
assumes Omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧Ω * z"
begin
lemma Omega_unfold_equal:
"y⇧Ω = 1 ⊔ y * y⇧Ω"
by (smt Omega_induct Omega_unfold sup_right_isotone order.antisym mult_right_isotone mult_1_right)
lemma Omega_sup_1:
"(x ⊔ y)⇧Ω = x⇧Ω * (y * x⇧Ω)⇧Ω"
apply (rule order.antisym)
apply (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute sup_right_isotone mult_assoc mult_right_dist_sup mult_right_isotone mult_1_right order_refl)
by (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute mult_assoc mult_left_one mult_right_dist_sup mult_1_right order_refl)
lemma Omega_left_slide:
"(x * y)⇧Ω * x ≤ x * (y * x)⇧Ω"
proof -
have "1 ⊔ y * (x * y)⇧Ω * x ≤ 1 ⊔ y * x * (1 ⊔ (y * (x * y)⇧Ω) * x)"
by (smt Omega_unfold_equal sup_right_isotone mult_assoc mult_left_one mult_left_sub_dist_sup mult_right_dist_sup mult_right_isotone mult_1_right)
thus ?thesis
by (smt Omega_induct Omega_unfold_equal le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)
qed
end
text ‹Theorem 50.3›
sublocale general_refinement_algebra < Omega: left_conway_semiring where circ = Omega
apply unfold_locales
using Omega_unfold_equal apply simp
apply (simp add: Omega_left_slide)
by (simp add: Omega_sup_1)
context general_refinement_algebra
begin
lemma star_below_Omega:
"x⇧⋆ ≤ x⇧Ω"
by (metis Omega_induct mult_1_right order_refl star.circ_left_unfold)
lemma star_mult_Omega:
"x⇧Ω = x⇧⋆ * x⇧Ω"
by (metis Omega.left_plus_below_circ sup_commute sup_ge1 order.eq_iff star.circ_loop_fixpoint star_left_induct_mult_iff)
lemma Omega_one_greatest:
"x ≤ 1⇧Ω"
by (metis Omega_induct sup_bot_left mult_left_one order_refl order_trans zero_right_mult_decreasing)
lemma greatest_left_zero:
"1⇧Ω * x = 1⇧Ω"
by (simp add: Omega_one_greatest Omega_induct order.antisym)
end
class bounded_general_refinement_algebra = general_refinement_algebra + bounded_left_kleene_algebra
begin
lemma Omega_one:
"1⇧Ω = top"
by (simp add: Omega_one_greatest order.antisym)
lemma top_left_zero:
"top * x = top"
using Omega_one greatest_left_zero by blast
end
sublocale bounded_general_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..
class left_demonic_refinement_algebra = general_refinement_algebra +
assumes Omega_isolate: "y⇧Ω ≤ y⇧Ω * bot ⊔ y⇧⋆"
begin
lemma Omega_isolate_equal:
"y⇧Ω = y⇧Ω * bot ⊔ y⇧⋆"
using Omega_isolate order.antisym le_sup_iff star_below_Omega zero_right_mult_decreasing by auto
end
class bounded_left_demonic_refinement_algebra = left_demonic_refinement_algebra + bounded_left_kleene_algebra
begin
end
sublocale bounded_left_demonic_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..
class demonic_refinement_algebra = left_zero_kleene_algebra + left_demonic_refinement_algebra
begin
lemma Omega_mult:
"(x * y)⇧Ω = 1 ⊔ x * (y * x)⇧Ω * y"
by (smt (verit, del_insts) Omega.circ_left_slide Omega_induct Omega_unfold_equal order.eq_iff mult_assoc mult_left_dist_sup mult_1_right)
lemma Omega_sup:
"(x ⊔ y)⇧Ω = (x⇧Ω * y)⇧Ω * x⇧Ω"
by (smt Omega_sup_1 Omega_mult mult_assoc mult_left_dist_sup mult_left_one mult_right_dist_sup mult_1_right)
lemma Omega_simulate:
"z * x ≤ y * z ⟹ z * x⇧Ω ≤ y⇧Ω * z"
by (smt Omega_induct Omega_unfold_equal sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone mult_1_right)
end
text ‹Theorem 2.4›
sublocale demonic_refinement_algebra < Omega1: itering_1 where circ = Omega
apply unfold_locales
apply (simp add: Omega_simulate mult_assoc)
by (simp add: Omega_simulate)
sublocale demonic_refinement_algebra < Omega1: left_zero_conway_semiring_1 where circ = Omega ..
context demonic_refinement_algebra
begin
lemma Omega_sum_unfold_1:
"(x ⊔ y)⇧Ω = y⇧Ω ⊔ y⇧⋆ * x * (x ⊔ y)⇧Ω"
by (smt Omega1.circ_sup_9 Omega.circ_loop_fixpoint Omega_isolate_equal sup_assoc sup_commute mult_assoc mult_left_zero mult_right_dist_sup)
lemma Omega_sup_3:
"(x ⊔ y)⇧Ω = (x⇧⋆ * y)⇧Ω * x⇧Ω"
apply (rule order.antisym)
apply (metis Omega_sum_unfold_1 Omega_induct eq_refl sup_commute)
by (simp add: Omega.circ_isotone Omega_sup mult_left_isotone star_below_Omega)
lemma Omega_separate_2:
"y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y)⇧Ω = x⇧Ω * y⇧Ω"
apply (rule order.antisym)
apply (smt (verit, del_insts) Omega_induct Omega_sum_unfold_1 sup_right_isotone mult_assoc mult_left_isotone star_mult_Omega star_simulation_left)
by (simp add: Omega.circ_sub_dist_3)
lemma Omega_circ_simulate_right_plus:
assumes "z * x ≤ y * y⇧Ω * z ⊔ w"
shows "z * x⇧Ω ≤ y⇧Ω * (z ⊔ w * x⇧Ω)"
proof -
have "z * x⇧Ω = z ⊔ z * x * x⇧Ω"
using Omega1.circ_back_loop_fixpoint Omega1.circ_plus_same sup_commute mult_assoc by auto
also have "... ≤ y * y⇧Ω * z * x⇧Ω ⊔ z ⊔ w * x⇧Ω"
by (smt assms sup_assoc sup_commute sup_right_isotone le_iff_sup mult_right_dist_sup)
finally have "z * x⇧Ω ≤ (y * y⇧Ω)⇧Ω * (z ⊔ w * x⇧Ω)"
by (smt Omega_induct sup_assoc sup_commute mult_assoc)
thus ?thesis
by (simp add: Omega.left_plus_circ)
qed
lemma Omega_circ_simulate_left_plus:
assumes "x * z ≤ z * y⇧Ω ⊔ w"
shows "x⇧Ω * z ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
proof -
have "x * ((z ⊔ x⇧Ω * w) * y⇧Ω) ≤ (z * y⇧Ω ⊔ w ⊔ x * x⇧Ω * w) * y⇧Ω"
by (smt assms mult_assoc mult_left_dist_sup sup_left_isotone mult_left_isotone)
also have "... ≤ z * y⇧Ω * y⇧Ω ⊔ w * y⇧Ω ⊔ x⇧Ω * w * y⇧Ω"
by (smt Omega.left_plus_below_circ sup_right_isotone mult_left_isotone mult_right_dist_sup)
finally have 1: "x * ((z ⊔ x⇧Ω * w) * y⇧Ω) ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
by (metis Omega.circ_transitive_equal mult_assoc Omega.circ_reflexive sup_assoc le_iff_sup mult_left_one mult_right_dist_sup)
have "x⇧Ω * z = x⇧Ω * bot ⊔ x⇧⋆ * z"
by (metis Omega_isolate_equal mult_assoc mult_left_zero mult_right_dist_sup)
also have "... ≤ x⇧Ω * w * y⇧Ω ⊔ x⇧⋆ * (z ⊔ x⇧Ω * w) * y⇧Ω"
by (metis Omega1.circ_back_loop_fixpoint bot_least idempotent_bot_closed le_supI2 mult_isotone mult_left_sub_dist_sup_left semiring.add_mono zero_right_mult_decreasing mult_assoc)
also have "... ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
using 1 by (metis le_supI mult_right_sub_dist_sup_right star_left_induct_mult mult_assoc)
finally show ?thesis
.
qed
lemma Omega_circ_simulate_right:
assumes "z * x ≤ y * z ⊔ w"
shows "z * x⇧Ω ≤ y⇧Ω * (z ⊔ w * x⇧Ω)"
proof -
have "y * z ⊔ w ≤ y * y⇧Ω * z ⊔ w"
using Omega.circ_mult_increasing mult_left_isotone sup_left_isotone by auto
thus ?thesis
using Omega_circ_simulate_right_plus assms order.trans by blast
qed
end
sublocale demonic_refinement_algebra < Omega: itering where circ = Omega
apply unfold_locales
apply (simp add: Omega_sup)
using Omega_mult apply blast
apply (simp add: Omega_circ_simulate_right_plus)
using Omega_circ_simulate_left_plus by auto
class bounded_demonic_refinement_algebra = demonic_refinement_algebra + bounded_left_zero_kleene_algebra
begin
lemma Omega_one:
"1⇧Ω = top"
by (simp add: Omega_one_greatest order.antisym)
lemma top_left_zero:
"top * x = top"
using Omega_one greatest_left_zero by auto
end
sublocale bounded_demonic_refinement_algebra < Omega: bounded_itering where circ = Omega ..
class general_refinement_algebra_omega = left_omega_algebra + Omega +
assumes omega_left_zero: "x⇧ω ≤ x⇧ω * y"
assumes Omega_def: "x⇧Ω = x⇧ω ⊔ x⇧⋆"
begin
lemma omega_left_zero_equal:
"x⇧ω * y = x⇧ω"
by (simp add: order.antisym omega_left_zero omega_sub_vector)
subclass left_demonic_refinement_algebra
apply unfold_locales
apply (metis Omega_def sup_commute eq_refl mult_1_right omega_loop_fixpoint)
apply (metis Omega_def mult_right_dist_sup omega_induct omega_left_zero_equal)
by (metis Omega_def mult_right_sub_dist_sup_right sup_commute sup_right_isotone omega_left_zero_equal)
end
class left_demonic_refinement_algebra_omega = bounded_left_omega_algebra + Omega +
assumes top_left_zero: "top * x = top"
assumes Omega_def: "x⇧Ω = x⇧ω ⊔ x⇧⋆"
begin
subclass general_refinement_algebra_omega
apply unfold_locales
apply (metis mult_assoc omega_vector order_refl top_left_zero)
by (rule Omega_def)
end
class demonic_refinement_algebra_omega = left_demonic_refinement_algebra_omega + bounded_left_zero_omega_algebra
begin
lemma Omega_mult:
"(x * y)⇧Ω = 1 ⊔ x * (y * x)⇧Ω * y"
by (metis Omega_def comb1.circ_mult_1 omega_left_zero_equal omega_translate)
lemma Omega_sup:
"(x ⊔ y)⇧Ω = (x⇧Ω * y)⇧Ω * x⇧Ω"
proof -
have "(x⇧Ω * y)⇧Ω * x⇧Ω = (x⇧⋆ * y)⇧⋆ * x⇧ω ⊔ (x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * x⇧ω⇧⋆ * x⇧Ω"
by (smt sup_commute Omega_def mult_assoc mult_right_dist_sup mult_bot_add_omega omega_left_zero_equal star.circ_sup_1)
thus ?thesis
using Omega_def Omega_sup_1 comb2.circ_slide_1 omega_left_zero_equal by auto
qed
lemma Omega_simulate:
"z * x ≤ y * z ⟹ z * x⇧Ω ≤ y⇧Ω * z"
using Omega_def comb2.circ_simulate omega_left_zero_equal by auto
subclass demonic_refinement_algebra ..
end
end
Theory Lattice_Ordered_Semirings
section ‹Lattice-Ordered Semirings›
theory Lattice_Ordered_Semirings
imports Stone_Relation_Algebras.Semirings
begin
text ‹Many results in this theory are taken from a joint paper with Rudolf Berghammer.›
text ‹M0-algebra›
class lattice_ordered_pre_left_semiring = pre_left_semiring + bounded_distrib_lattice
begin
subclass bounded_pre_left_semiring
apply unfold_locales
by simp
lemma top_mult_right_one:
"x * top = x * top * 1"
by (metis order.antisym mult_sub_right_one mult_sup_associative_one surjective_one_closed)
lemma mult_left_sub_dist_inf_left:
"x * (y ⊓ z) ≤ x * y"
by (simp add: mult_right_isotone)
lemma mult_left_sub_dist_inf_right:
"x * (y ⊓ z) ≤ x * z"
by (simp add: mult_right_isotone)
lemma mult_right_sub_dist_inf_left:
"(x ⊓ y) * z ≤ x * z"
by (simp add: mult_left_isotone)
lemma mult_right_sub_dist_inf_right:
"(x ⊓ y) * z ≤ y * z"
by (simp add: mult_left_isotone)
lemma mult_right_sub_dist_inf:
"(x ⊓ y) * z ≤ x * z ⊓ y * z"
by (simp add: mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right)
text ‹Figure 1: fundamental properties›
definition co_total :: "'a ⇒ bool" where "co_total x ≡ x * bot = bot"
definition up_closed :: "'a ⇒ bool" where "up_closed x ≡ x * 1 = x"
definition sup_distributive :: "'a ⇒ bool" where "sup_distributive x ≡ (∀y z . x * (y ⊔ z) = x * y ⊔ x * z)"
definition inf_distributive :: "'a ⇒ bool" where "inf_distributive x ≡ (∀y z . x * (y ⊓ z) = x * y ⊓ x * z)"
definition contact :: "'a ⇒ bool" where "contact x ≡ x * x ⊔ 1 = x"
definition kernel :: "'a ⇒ bool" where "kernel x ≡ x * x ⊓ 1 = x * 1"
definition sup_dist_contact :: "'a ⇒ bool" where "sup_dist_contact x ≡ sup_distributive x ∧ contact x"
definition inf_dist_kernel :: "'a ⇒ bool" where "inf_dist_kernel x ≡ inf_distributive x ∧ kernel x"
definition test :: "'a ⇒ bool" where "test x ≡ x * top ⊓ 1 = x"
definition co_test :: "'a ⇒ bool" where "co_test x ≡ x * bot ⊔ 1 = x"
definition co_vector :: "'a ⇒ bool" where "co_vector x ≡ x * bot = x"
text ‹AAMP Theorem 6 / Figure 2: relations between properties›
lemma reflexive_total:
"reflexive x ⟹ total x"
using sup_left_divisibility total_sup_closed by force
lemma reflexive_dense:
"reflexive x ⟹ dense_rel x"
using mult_left_isotone by fastforce
lemma reflexive_transitive_up_closed:
"reflexive x ⟹ transitive x ⟹ up_closed x"
by (metis antisym_conv mult_isotone mult_sub_right_one reflexive_dense up_closed_def)
lemma coreflexive_co_total:
"coreflexive x ⟹ co_total x"
by (metis co_total_def order.eq_iff mult_left_isotone mult_left_one bot_least)
lemma coreflexive_transitive:
"coreflexive x ⟹ transitive x"
by (simp add: coreflexive_transitive)
lemma idempotent_transitive_dense:
"idempotent x ⟷ transitive x ∧ dense_rel x"
by (simp add: order.eq_iff)
lemma contact_reflexive:
"contact x ⟹ reflexive x"
using contact_def sup_right_divisibility by auto
lemma contact_transitive:
"contact x ⟹ transitive x"
using contact_def sup_left_divisibility by blast
lemma contact_dense:
"contact x ⟹ dense_rel x"
by (simp add: contact_reflexive reflexive_dense)
lemma contact_idempotent:
"contact x ⟹ idempotent x"
by (simp add: contact_dense contact_transitive idempotent_transitive_dense)
lemma contact_up_closed:
"contact x ⟹ up_closed x"
by (simp add: contact_reflexive contact_transitive reflexive_transitive_up_closed)
lemma contact_reflexive_idempotent_up_closed:
"contact x ⟷ reflexive x ∧ idempotent x ∧ up_closed x"
by (metis contact_def contact_idempotent contact_reflexive contact_up_closed sup_absorb2 sup_monoid.add_commute)
lemma kernel_coreflexive:
"kernel x ⟹ coreflexive x"
by (metis kernel_def inf.boundedE mult_sub_right_one)
lemma kernel_transitive:
"kernel x ⟹ transitive x"
by (simp add: coreflexive_transitive kernel_coreflexive)
lemma kernel_dense:
"kernel x ⟹ dense_rel x"
by (metis kernel_def inf.boundedE mult_sub_right_one)
lemma kernel_idempotent:
"kernel x ⟹ idempotent x"
by (simp add: idempotent_transitive_dense kernel_dense kernel_transitive)
lemma kernel_up_closed:
"kernel x ⟹ up_closed x"
by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)
lemma kernel_coreflexive_idempotent_up_closed:
"kernel x ⟷ coreflexive x ∧ idempotent x ∧ up_closed x"
by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)
lemma test_coreflexive:
"test x ⟹ coreflexive x"
using inf.sup_right_divisibility test_def by blast
lemma test_up_closed:
"test x ⟹ up_closed x"
by (metis order.eq_iff mult_left_one mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one up_closed_def)
lemma co_test_reflexive:
"co_test x ⟹ reflexive x"
using co_test_def sup_right_divisibility by blast
lemma co_test_transitive:
"co_test x ⟹ transitive x"
by (smt co_test_def sup_assoc le_iff_sup mult_left_one mult_left_zero mult_right_dist_sup mult_semi_associative)
lemma co_test_idempotent:
"co_test x ⟹ idempotent x"
by (simp add: co_test_reflexive co_test_transitive idempotent_transitive_dense reflexive_dense)
lemma co_test_up_closed:
"co_test x ⟹ up_closed x"
by (simp add: co_test_reflexive co_test_transitive reflexive_transitive_up_closed)
lemma co_test_contact:
"co_test x ⟹ contact x"
by (simp add: co_test_idempotent co_test_reflexive co_test_up_closed contact_reflexive_idempotent_up_closed)
lemma vector_transitive:
"vector x ⟹ transitive x"
by (metis mult_right_isotone top.extremum)
lemma vector_up_closed:
"vector x ⟹ up_closed x"
by (metis top_mult_right_one up_closed_def)
text ‹AAMP Theorem 10 / Figure 3: closure properties›
text ‹total›
lemma one_total:
"total 1"
by simp
lemma top_total:
"total top"
by simp
lemma sup_total:
"total x ⟹ total y ⟹ total (x ⊔ y)"
by (simp add: total_sup_closed)
text ‹co-total›
lemma zero_co_total:
"co_total bot"
by (simp add: co_total_def)
lemma one_co_total:
"co_total 1"
by (simp add: co_total_def)
lemma sup_co_total:
"co_total x ⟹ co_total y ⟹ co_total (x ⊔ y)"
by (simp add: co_total_def mult_right_dist_sup)
lemma inf_co_total:
"co_total x ⟹ co_total y ⟹ co_total (x ⊓ y)"
by (metis co_total_def order.antisym bot_least mult_right_sub_dist_inf_right)
lemma comp_co_total:
"co_total x ⟹ co_total y ⟹ co_total (x * y)"
by (metis co_total_def order.eq_iff mult_semi_associative bot_least)
text ‹sub-transitive›
lemma zero_transitive:
"transitive bot"
by (simp add: vector_transitive)
lemma one_transitive:
"transitive 1"
by simp
lemma top_transitive:
"transitive top"
by simp
lemma inf_transitive:
"transitive x ⟹ transitive y ⟹ transitive (x ⊓ y)"
by (meson inf_mono order_trans mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right mult_right_sub_dist_inf)
text ‹dense›
lemma zero_dense:
"dense_rel bot"
by simp
lemma one_dense:
"dense_rel 1"
by simp
lemma top_dense:
"dense_rel top"
by simp
lemma sup_dense:
assumes "dense_rel x"
and "dense_rel y"
shows "dense_rel (x ⊔ y)"
proof -
have "x ≤ x * x ∧ y ≤ y * y"
using assms by auto
hence "x ≤ (x ⊔ y) * (x ⊔ y) ∧ y ≤ (x ⊔ y) * (x ⊔ y)"
by (meson dense_sup_closed order_trans sup.cobounded1 sup.cobounded2)
hence "x ⊔ y ≤ (x ⊔ y) * (x ⊔ y)"
by simp
thus "dense_rel (x ⊔ y)"
by simp
qed
text ‹reflexive›
lemma one_reflexive:
"reflexive 1"
by simp
lemma top_reflexive:
"reflexive top"
by simp
lemma sup_reflexive:
"reflexive x ⟹ reflexive y ⟹ reflexive (x ⊔ y)"
by (simp add: reflexive_sup_closed)
lemma inf_reflexive:
"reflexive x ⟹ reflexive y ⟹ reflexive (x ⊓ y)"
by simp
lemma comp_reflexive:
"reflexive x ⟹ reflexive y ⟹ reflexive (x * y)"
using reflexive_mult_closed by auto
text ‹co-reflexive›
lemma zero_coreflexive:
"coreflexive bot"
by simp
lemma one_coreflexive:
"coreflexive 1"
by simp
lemma sup_coreflexive:
"coreflexive x ⟹ coreflexive y ⟹ coreflexive (x ⊔ y)"
by simp
lemma inf_coreflexive:
"coreflexive x ⟹ coreflexive y ⟹ coreflexive (x ⊓ y)"
by (simp add: le_infI1)
lemma comp_coreflexive:
"coreflexive x ⟹ coreflexive y ⟹ coreflexive (x * y)"
by (simp add: coreflexive_mult_closed)
text ‹idempotent›
lemma zero_idempotent:
"idempotent bot"
by simp
lemma one_idempotent:
"idempotent 1"
by simp
lemma top_idempotent:
"idempotent top"
by simp
text ‹up-closed›
lemma zero_up_closed:
"up_closed bot"
by (simp add: up_closed_def)
lemma one_up_closed:
"up_closed 1"
by (simp add: up_closed_def)
lemma top_up_closed:
"up_closed top"
by (simp add: vector_up_closed)
lemma sup_up_closed:
"up_closed x ⟹ up_closed y ⟹ up_closed (x ⊔ y)"
by (simp add: mult_right_dist_sup up_closed_def)
lemma inf_up_closed:
"up_closed x ⟹ up_closed y ⟹ up_closed (x ⊓ y)"
by (metis order.antisym mult_sub_right_one mult_right_sub_dist_inf up_closed_def)
lemma comp_up_closed:
"up_closed x ⟹ up_closed y ⟹ up_closed (x * y)"
by (metis order.antisym mult_semi_associative mult_sub_right_one up_closed_def)
text ‹add-distributive›
lemma zero_sup_distributive:
"sup_distributive bot"
by (simp add: sup_distributive_def)
lemma one_sup_distributive:
"sup_distributive 1"
by (simp add: sup_distributive_def)
lemma sup_sup_distributive:
"sup_distributive x ⟹ sup_distributive y ⟹ sup_distributive (x ⊔ y)"
using sup_distributive_def mult_right_dist_sup sup_monoid.add_assoc sup_monoid.add_commute by auto
text ‹inf-distributive›
lemma zero_inf_distributive:
"inf_distributive bot"
by (simp add: inf_distributive_def)
lemma one_inf_distributive:
"inf_distributive 1"
by (simp add: inf_distributive_def)
text ‹contact›
lemma one_contact:
"contact 1"
by (simp add: contact_def)
lemma top_contact:
"contact top"
by (simp add: contact_def)
lemma inf_contact:
"contact x ⟹ contact y ⟹ contact (x ⊓ y)"
by (meson contact_reflexive_idempotent_up_closed contact_transitive inf_reflexive inf_transitive inf_up_closed preorder_idempotent)
text ‹kernel›
lemma zero_kernel:
"kernel bot"
by (simp add: kernel_def)
lemma one_kernel:
"kernel 1"
by (simp add: kernel_def)
lemma sup_kernel:
"kernel x ⟹ kernel y ⟹ kernel (x ⊔ y)"
using kernel_coreflexive_idempotent_up_closed order.antisym coreflexive_transitive sup_dense sup_up_closed by force
text ‹add-distributive contact›
lemma one_sup_dist_contact:
"sup_dist_contact 1"
by (simp add: sup_dist_contact_def one_sup_distributive one_contact)
text ‹inf-distributive kernel›
lemma zero_inf_dist_kernel:
"inf_dist_kernel bot"
by (simp add: inf_dist_kernel_def zero_kernel zero_inf_distributive)
lemma one_inf_dist_kernel:
"inf_dist_kernel 1"
by (simp add: inf_dist_kernel_def one_kernel one_inf_distributive)
text ‹test›
lemma zero_test:
"test bot"
by (simp add: test_def)
lemma one_test:
"test 1"
by (simp add: test_def)
lemma sup_test:
"test x ⟹ test y ⟹ test (x ⊔ y)"
by (simp add: inf_sup_distrib2 mult_right_dist_sup test_def)
lemma inf_test:
"test x ⟹ test y ⟹ test (x ⊓ y)"
by (smt (z3) inf.left_commute idempotent_one_closed inf.le_iff_sup inf_top.right_neutral mult_right_isotone mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one)
text ‹co-test›
lemma one_co_test:
"co_test 1"
by (simp add: co_test_def)
lemma sup_co_test:
"co_test x ⟹ co_test y ⟹ co_test (x ⊔ y)"
by (smt (z3) co_test_def mult_right_dist_sup sup.left_idem sup_assoc sup_commute)
text ‹vector›
lemma zero_vector:
"vector bot"
by simp
lemma top_vector:
"vector top"
by simp
lemma sup_vector:
"vector x ⟹ vector y ⟹ vector (x ⊔ y)"
by (simp add: vector_sup_closed)
lemma inf_vector:
"vector x ⟹ vector y ⟹ vector (x ⊓ y)"
by (metis order.antisym top_right_mult_increasing mult_right_sub_dist_inf)
lemma comp_vector:
"vector y ⟹ vector (x * y)"
by (simp add: vector_mult_closed)
end
class lattice_ordered_pre_left_semiring_1 = non_associative_left_semiring + bounded_distrib_lattice +
assumes mult_associative_one: "x * (y * z) = (x * (y * 1)) * z"
assumes mult_right_dist_inf_one: "(x * 1 ⊓ y * 1) * z = x * z ⊓ y * z"
begin
subclass pre_left_semiring
apply unfold_locales
by (metis mult_associative_one mult_left_isotone mult_right_isotone mult_sub_right_one)
subclass lattice_ordered_pre_left_semiring ..
lemma mult_zero_associative:
"x * bot * y = x * bot"
by (metis mult_associative_one mult_left_zero)
lemma mult_zero_sup_one_dist:
"(x * bot ⊔ 1) * z = x * bot ⊔ z"
by (simp add: mult_right_dist_sup mult_zero_associative)
lemma mult_zero_sup_dist:
"(x * bot ⊔ y) * z = x * bot ⊔ y * z"
by (simp add: mult_right_dist_sup mult_zero_associative)
lemma vector_zero_inf_one_comp:
"(x * bot ⊓ 1) * y = x * bot ⊓ y"
by (metis mult_left_one mult_right_dist_inf_one mult_zero_associative)
text ‹AAMP Theorem 6 / Figure 2: relations between properties›
lemma co_test_inf_distributive:
"co_test x ⟹ inf_distributive x"
by (metis co_test_def distrib_imp1 inf_sup_distrib1 inf_distributive_def mult_zero_sup_one_dist)
lemma co_test_sup_distributive:
"co_test x ⟹ sup_distributive x"
by (metis sup_sup_distributive sup_distributive_def co_test_def one_sup_distributive sup.idem mult_zero_associative)
lemma co_test_sup_dist_contact:
"co_test x ⟹ sup_dist_contact x"
by (simp add: co_test_sup_distributive sup_dist_contact_def co_test_contact)
text ‹AAMP Theorem 10 / Figure 3: closure properties›
text ‹co-test›
lemma inf_co_test:
"co_test x ⟹ co_test y ⟹ co_test (x ⊓ y)"
by (smt (z3) co_test_def co_test_up_closed mult_right_dist_inf_one sup_commute sup_inf_distrib1 up_closed_def)
lemma comp_co_test:
"co_test x ⟹ co_test y ⟹ co_test (x * y)"
by (metis co_test_def mult_associative_one sup_assoc mult_zero_sup_one_dist)
end
class lattice_ordered_pre_left_semiring_2 = lattice_ordered_pre_left_semiring +
assumes mult_sub_associative_one: "x * (y * z) ≤ (x * (y * 1)) * z"
assumes mult_right_dist_inf_one_sub: "x * z ⊓ y * z ≤ (x * 1 ⊓ y * 1) * z"
begin
subclass lattice_ordered_pre_left_semiring_1
apply unfold_locales
apply (simp add: order.antisym mult_sub_associative_one mult_sup_associative_one)
by (metis order.eq_iff mult_one_associative mult_right_dist_inf_one_sub mult_right_sub_dist_inf)
end
class multirelation_algebra_1 = lattice_ordered_pre_left_semiring +
assumes mult_left_top: "top * x = top"
begin
text ‹AAMP Theorem 10 / Figure 3: closure properties›
lemma top_sup_distributive:
"sup_distributive top"
by (simp add: sup_distributive_def mult_left_top)
lemma top_inf_distributive:
"inf_distributive top"
by (simp add: inf_distributive_def mult_left_top)
lemma top_sup_dist_contact:
"sup_dist_contact top"
by (simp add: sup_dist_contact_def top_contact top_sup_distributive)
lemma top_co_test:
"co_test top"
by (simp add: co_test_def mult_left_top)
end
text ‹M1-algebra›
class multirelation_algebra_2 = multirelation_algebra_1 + lattice_ordered_pre_left_semiring_2
begin
lemma mult_top_associative:
"x * top * y = x * top"
by (metis mult_left_top mult_associative_one)
lemma vector_inf_one_comp:
"(x * top ⊓ 1) * y = x * top ⊓ y"
by (metis vector_zero_inf_one_comp mult_top_associative)
lemma vector_left_annihilator:
"vector x ⟹ x * y = x"
by (metis mult_top_associative)
text ‹properties›
lemma test_comp_inf:
"test x ⟹ test y ⟹ x * y = x ⊓ y"
by (metis inf.absorb1 inf.left_commute test_coreflexive test_def vector_inf_one_comp)
text ‹AAMP Theorem 6 / Figure 2: relations between properties›
lemma test_sup_distributive:
"test x ⟹ sup_distributive x"
by (metis sup_distributive_def inf_sup_distrib1 test_def vector_inf_one_comp)
lemma test_inf_distributive:
"test x ⟹ inf_distributive x"
by (smt (verit, ccfv_SIG) inf.commute inf.sup_monoid.add_assoc inf_distributive_def test_def inf.idem vector_inf_one_comp)
lemma test_inf_dist_kernel:
"test x ⟹ inf_dist_kernel x"
by (simp add: kernel_def inf_dist_kernel_def one_test test_comp_inf test_inf_distributive)
lemma vector_idempotent:
"vector x ⟹ idempotent x"
using vector_left_annihilator by blast
lemma vector_sup_distributive:
"vector x ⟹ sup_distributive x"
by (simp add: sup_distributive_def vector_left_annihilator)
lemma vector_inf_distributive:
"vector x ⟹ inf_distributive x"
by (simp add: inf_distributive_def vector_left_annihilator)
lemma vector_co_vector:
"vector x ⟷ co_vector x"
by (metis co_vector_def mult_zero_associative mult_top_associative)
text ‹AAMP Theorem 10 / Figure 3: closure properties›
text ‹test›
lemma comp_test:
"test x ⟹ test y ⟹ test (x * y)"
by (simp add: inf_test test_comp_inf)
end
class dual =
fixes dual :: "'a ⇒ 'a" ("_⇧d" [100] 100)
class multirelation_algebra_3 = lattice_ordered_pre_left_semiring + dual +
assumes dual_involutive: "x⇧d⇧d = x"
assumes dual_dist_sup: "(x ⊔ y)⇧d = x⇧d ⊓ y⇧d"
assumes dual_one: "1⇧d = 1"
begin
lemma dual_dist_inf:
"(x ⊓ y)⇧d = x⇧d ⊔ y⇧d"
by (metis dual_dist_sup dual_involutive)
lemma dual_antitone:
"x ≤ y ⟹ y⇧d ≤ x⇧d"
using dual_dist_sup sup_right_divisibility by fastforce
lemma dual_zero:
"bot⇧d = top"
by (metis dual_antitone bot_least dual_involutive top_le)
lemma dual_top:
"top⇧d = bot"
using dual_zero dual_involutive by auto
text ‹AAMP Theorem 10 / Figure 3: closure properties›
lemma reflexive_coreflexive_dual:
"reflexive x ⟷ coreflexive (x⇧d)"
using dual_antitone dual_involutive dual_one by fastforce
end
class multirelation_algebra_4 = multirelation_algebra_3 +
assumes dual_sub_dist_comp: "(x * y)⇧d ≤ x⇧d * y⇧d"
begin
subclass multirelation_algebra_1
apply unfold_locales
by (metis order.antisym top.extremum dual_zero dual_sub_dist_comp dual_involutive mult_left_zero)
lemma dual_sub_dist_comp_one:
"(x * y)⇧d ≤ (x * 1)⇧d * y⇧d"
by (metis dual_sub_dist_comp mult_one_associative)
text ‹AAMP Theorem 10 / Figure 3: closure properties›
lemma co_total_total_dual:
"co_total x ⟹ total (x⇧d)"
by (metis co_total_def dual_sub_dist_comp dual_zero top_le)
lemma transitive_dense_dual:
"transitive x ⟹ dense_rel (x⇧d)"
using dual_antitone dual_sub_dist_comp inf.order_lesseq_imp by blast
end
text ‹M2-algebra›
class multirelation_algebra_5 = multirelation_algebra_3 +
assumes dual_dist_comp_one: "(x * y)⇧d = (x * 1)⇧d * y⇧d"
begin
subclass multirelation_algebra_4
apply unfold_locales
by (metis dual_antitone mult_sub_right_one mult_left_isotone dual_dist_comp_one)
lemma strong_up_closed:
"x * 1 ≤ x ⟹ x⇧d * y⇧d ≤ (x * y)⇧d"
by (simp add: dual_dist_comp_one antisym_conv mult_sub_right_one)
lemma strong_up_closed_2:
"up_closed x ⟹ (x * y)⇧d = x⇧d * y⇧d"
by (simp add: dual_dist_comp_one up_closed_def)
subclass lattice_ordered_pre_left_semiring_2
apply unfold_locales
apply (smt comp_up_closed dual_antitone dual_dist_comp_one dual_involutive dual_one mult_left_one mult_one_associative mult_semi_associative up_closed_def strong_up_closed_2)
by (smt dual_dist_comp_one dual_dist_inf dual_involutive eq_refl mult_one_associative mult_right_dist_sup)
text ‹AAMP Theorem 8›
subclass multirelation_algebra_2 ..
text ‹AAMP Theorem 10 / Figure 3: closure properties›
text ‹up-closed›
lemma dual_up_closed:
"up_closed x ⟷ up_closed (x⇧d)"
by (metis dual_involutive dual_one up_closed_def strong_up_closed_2)
text ‹contact›
lemma contact_kernel_dual:
"contact x ⟷ kernel (x⇧d)"
by (metis contact_def contact_up_closed dual_dist_sup dual_involutive dual_one kernel_def kernel_up_closed up_closed_def strong_up_closed_2)
text ‹add-distributive contact›
lemma sup_dist_contact_inf_dist_kernel_dual:
"sup_dist_contact x ⟷ inf_dist_kernel (x⇧d)"
proof
assume 1: "sup_dist_contact x"
hence 2: "up_closed x"
using sup_dist_contact_def contact_up_closed by auto
have "sup_distributive x"
using 1 sup_dist_contact_def by auto
hence "inf_distributive (x⇧d)"
using 2 by (smt sup_distributive_def dual_dist_comp_one dual_dist_inf dual_involutive inf_distributive_def up_closed_def)
thus "inf_dist_kernel (x⇧d)"
using 1 contact_kernel_dual sup_dist_contact_def inf_dist_kernel_def by blast
next
assume 3: "inf_dist_kernel (x⇧d)"
hence 4: "up_closed (x⇧d)"
using kernel_up_closed inf_dist_kernel_def by auto
have "inf_distributive (x⇧d)"
using 3 inf_dist_kernel_def by auto
hence "sup_distributive (x⇧d⇧d)"
using 4 by (smt inf_distributive_def sup_distributive_def dual_dist_sup dual_involutive strong_up_closed_2)
thus "sup_dist_contact x"
using 3 contact_kernel_dual sup_dist_contact_def dual_involutive inf_dist_kernel_def by auto
qed
text ‹test›
lemma test_co_test_dual:
"test x ⟷ co_test (x⇧d)"
by (smt (z3) co_test_def co_test_up_closed dual_dist_comp_one dual_dist_inf dual_involutive dual_one dual_top test_def test_up_closed up_closed_def)
text ‹vector›
lemma vector_dual:
"vector x ⟷ vector (x⇧d)"
by (metis dual_dist_comp_one dual_involutive mult_top_associative)
end
class multirelation_algebra_6 = multirelation_algebra_4 +
assumes dual_sub_dist_comp_one: "(x * 1)⇧d * y⇧d ≤ (x * y)⇧d"
begin
subclass multirelation_algebra_5
apply unfold_locales
by (metis dual_sub_dist_comp dual_sub_dist_comp_one order.eq_iff mult_one_associative)
end
text ‹M3-algebra›
class up_closed_multirelation_algebra = multirelation_algebra_3 +
assumes dual_dist_comp: "(x * y)⇧d = x⇧d * y⇧d"
begin
lemma mult_right_dist_inf:
"(x ⊓ y) * z = x * z ⊓ y * z"
by (metis dual_dist_sup dual_dist_comp dual_involutive mult_right_dist_sup)
text ‹AAMP Theorem 9›
subclass idempotent_left_semiring
apply unfold_locales
apply (metis order.antisym dual_antitone dual_dist_comp dual_involutive mult_semi_associative)
apply simp
by (metis order.antisym dual_antitone dual_dist_comp dual_involutive dual_one mult_sub_right_one)
subclass multirelation_algebra_6
apply unfold_locales
by (simp_all add: dual_dist_comp)
lemma vector_inf_comp:
"(x * top ⊓ y) * z = x * top ⊓ y * z"
by (simp add: vector_left_annihilator mult_right_dist_inf mult.assoc)
lemma vector_zero_inf_comp:
"(x * bot ⊓ y) * z = x * bot ⊓ y * z"
by (simp add: mult_right_dist_inf mult.assoc)
text ‹AAMP Theorem 10 / Figure 3: closure properties›
text ‹total›
lemma inf_total:
"total x ⟹ total y ⟹ total (x ⊓ y)"
by (simp add: mult_right_dist_inf)
lemma comp_total:
"total x ⟹ total y ⟹ total (x * y)"
by (simp add: mult_assoc)
lemma total_co_total_dual:
"total x ⟷ co_total (x⇧d)"
by (metis co_total_def dual_dist_comp dual_involutive dual_top)
text ‹dense›
lemma transitive_iff_dense_dual:
"transitive x ⟷ dense_rel (x⇧d)"
by (metis dual_antitone dual_dist_comp dual_involutive)
text ‹idempotent›
lemma idempotent_dual:
"idempotent x ⟷ idempotent (x⇧d)"
using dual_involutive idempotent_transitive_dense transitive_iff_dense_dual by auto
text ‹add-distributive›
lemma comp_sup_distributive:
"sup_distributive x ⟹ sup_distributive y ⟹ sup_distributive (x * y)"
by (simp add: sup_distributive_def mult.assoc)
lemma sup_inf_distributive_dual:
"sup_distributive x ⟷ inf_distributive (x⇧d)"
by (smt (verit, ccfv_threshold) sup_distributive_def dual_dist_sup dual_dist_comp dual_dist_inf dual_involutive inf_distributive_def)
text ‹inf-distributive›
lemma inf_inf_distributive:
"inf_distributive x ⟹ inf_distributive y ⟹ inf_distributive (x ⊓ y)"
by (metis sup_inf_distributive_dual sup_sup_distributive dual_dist_inf dual_involutive)
lemma comp_inf_distributive:
"inf_distributive x ⟹ inf_distributive y ⟹ inf_distributive (x * y)"
by (simp add: inf_distributive_def mult.assoc)
end
class multirelation_algebra_7 = multirelation_algebra_4 +
assumes vector_inf_comp: "(x * top ⊓ y) * z = x * top ⊓ y * z"
begin
lemma vector_zero_inf_comp:
"(x * bot ⊓ y) * z = x * bot ⊓ y * z"
by (metis vector_inf_comp vector_mult_closed zero_vector)
lemma test_sup_distributive:
"test x ⟹ sup_distributive x"
by (metis sup_distributive_def inf_sup_distrib1 mult_left_one test_def vector_inf_comp)
lemma test_inf_distributive:
"test x ⟹ inf_distributive x"
by (smt (z3) inf.right_idem inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_distributive_def mult_left_one test_def vector_inf_comp)
lemma test_inf_dist_kernel:
"test x ⟹ inf_dist_kernel x"
by (metis inf.idem inf.sup_monoid.add_assoc kernel_def inf_dist_kernel_def mult_left_one test_def test_inf_distributive vector_inf_comp)
lemma co_test_inf_distributive:
assumes "co_test x"
shows "inf_distributive x"
proof -
have "x = x * bot ⊔ 1"
using assms co_test_def by auto
hence "∀y z . x * y ⊓ x * z = x * (y ⊓ z)"
by (metis distrib_imp1 inf_sup_absorb inf_sup_distrib1 mult_left_one mult_left_top mult_right_dist_sup sup_top_right vector_zero_inf_comp)
thus "inf_distributive x"
by (simp add: inf_distributive_def)
qed
lemma co_test_sup_distributive:
assumes "co_test x"
shows "sup_distributive x"
proof -
have "x = x * bot ⊔ 1"
using assms co_test_def by auto
hence "∀y z . x * (y ⊔ z) = x * y ⊔ x * z"
by (metis sup_sup_distributive sup_distributive_def inf_sup_absorb mult_left_top one_sup_distributive sup.idem sup_top_right vector_zero_inf_comp)
thus "sup_distributive x"
by (simp add: sup_distributive_def)
qed
lemma co_test_sup_dist_contact:
"co_test x ⟹ sup_dist_contact x"
by (simp add: sup_dist_contact_def co_test_sup_distributive co_test_contact)
end
end
Theory Boolean_Semirings
section ‹Boolean Semirings›
theory Boolean_Semirings
imports Stone_Algebras.P_Algebras Lattice_Ordered_Semirings
begin
class complemented_distributive_lattice = bounded_distrib_lattice + uminus +
assumes inf_complement: "x ⊓ (-x) = bot"
assumes sup_complement: "x ⊔ (-x) = top"
begin
sublocale boolean_algebra where minus = "λx y . x ⊓ (-y)" and inf = inf and sup = sup and bot = bot and top = top
apply unfold_locales
apply (simp add: inf_complement)
apply (simp add: sup_complement)
by simp
end
text ‹M0-algebra›
context lattice_ordered_pre_left_semiring
begin
text ‹Section 7›
lemma vector_1:
"vector x ⟷ x * top ≤ x"
by (simp add: antisym_conv top_right_mult_increasing)
definition zero_vector :: "'a ⇒ bool" where "zero_vector x ≡ x ≤ x * bot"
definition one_vector :: "'a ⇒ bool" where "one_vector x ≡ x * bot ≤ x"
lemma zero_vector_left_zero:
assumes "zero_vector x"
shows "x * y = x * bot"
proof -
have "x * y ≤ x * bot"
by (metis assms mult_isotone top.extremum vector_mult_closed zero_vector zero_vector_def)
thus ?thesis
by (simp add: order.antisym mult_right_isotone)
qed
lemma zero_vector_1:
"zero_vector x ⟷ (∀y . x * y = x * bot)"
by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)
lemma zero_vector_2:
"zero_vector x ⟷ (∀y . x * y ≤ x * bot)"
by (metis eq_refl order_trans top_right_mult_increasing zero_vector_def zero_vector_left_zero)
lemma zero_vector_3:
"zero_vector x ⟷ x * 1 = x * bot"
by (metis mult_sub_right_one zero_vector_def zero_vector_left_zero)
lemma zero_vector_4:
"zero_vector x ⟷ x * 1 ≤ x * bot"
using order.antisym mult_right_isotone zero_vector_3 by auto
lemma zero_vector_5:
"zero_vector x ⟷ x * top = x * bot"
by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)
lemma zero_vector_6:
"zero_vector x ⟷ x * top ≤ x * bot"
by (meson mult_right_isotone order_trans top.extremum zero_vector_2)
lemma zero_vector_7:
"zero_vector x ⟷ (∀y . x * top = x * y)"
by (metis zero_vector_1)
lemma zero_vector_8:
"zero_vector x ⟷ (∀y . x * top ≤ x * y)"
by (metis zero_vector_6 zero_vector_left_zero)
lemma zero_vector_9:
"zero_vector x ⟷ (∀y . x * 1 = x * y)"
by (metis zero_vector_1)
lemma zero_vector_0:
"zero_vector x ⟷ (∀y z . x * y = x * z)"
by (metis zero_vector_5 zero_vector_left_zero)
text ‹Theorem 6 / Figure 2: relations between properties›
lemma co_vector_zero_vector_one_vector:
"co_vector x ⟷ zero_vector x ∧ one_vector x"
using co_vector_def one_vector_def zero_vector_def by auto
lemma up_closed_one_vector:
"up_closed x ⟹ one_vector x"
by (metis bot_least mult_right_isotone up_closed_def one_vector_def)
lemma zero_vector_dense:
"zero_vector x ⟹ dense_rel x"
by (metis zero_vector_0 zero_vector_def)
lemma zero_vector_sup_distributive:
"zero_vector x ⟹ sup_distributive x"
by (metis sup_distributive_def sup_idem zero_vector_0)
lemma zero_vector_inf_distributive:
"zero_vector x ⟹ inf_distributive x"
by (metis inf_idem inf_distributive_def zero_vector_0)
lemma up_closed_zero_vector_vector:
"up_closed x ⟹ zero_vector x ⟹ vector x"
by (metis up_closed_def zero_vector_0)
lemma zero_vector_one_vector_vector:
"zero_vector x ⟹ one_vector x ⟹ vector x"
by (metis one_vector_def vector_1 zero_vector_0)
lemma co_vector_vector:
"co_vector x ⟹ vector x"
by (simp add: co_vector_zero_vector_one_vector zero_vector_one_vector_vector)
text ‹Theorem 10 / Figure 3: closure properties›
text ‹zero-vector›
lemma zero_zero_vector:
"zero_vector bot"
by (simp add: zero_vector_def)
lemma sup_zero_vector:
"zero_vector x ⟹ zero_vector y ⟹ zero_vector (x ⊔ y)"
by (simp add: mult_right_dist_sup zero_vector_3)
lemma comp_zero_vector:
"zero_vector x ⟹ zero_vector y ⟹ zero_vector (x * y)"
by (metis mult_one_associative zero_vector_0)
text ‹one-vector›
lemma zero_one_vector:
"one_vector bot"
by (simp add: one_vector_def)
lemma one_one_vector:
"one_vector 1"
by (simp add: one_up_closed up_closed_one_vector)
lemma top_one_vector:
"one_vector top"
by (simp add: one_vector_def)
lemma sup_one_vector:
"one_vector x ⟹ one_vector y ⟹ one_vector (x ⊔ y)"
by (simp add: mult_right_dist_sup order_trans one_vector_def)
lemma inf_one_vector:
"one_vector x ⟹ one_vector y ⟹ one_vector (x ⊓ y)"
by (meson order.trans inf.boundedI mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right one_vector_def)
lemma comp_one_vector:
"one_vector x ⟹ one_vector y ⟹ one_vector (x * y)"
using mult_isotone mult_semi_associative order_lesseq_imp one_vector_def by blast
end
context multirelation_algebra_1
begin
text ‹Theorem 10 / Figure 3: closure properties›
text ‹zero-vector›
lemma top_zero_vector:
"zero_vector top"
by (simp add: mult_left_top zero_vector_def)
end
text ‹M1-algebra›
context multirelation_algebra_2
begin
text ‹Section 7›
lemma zero_vector_10:
"zero_vector x ⟷ x * top = x * 1"
by (metis mult_one_associative mult_top_associative zero_vector_7)
lemma zero_vector_11:
"zero_vector x ⟷ x * top ≤ x * 1"
using order.antisym mult_right_isotone zero_vector_10 by fastforce
text ‹Theorem 6 / Figure 2: relations between properties›
lemma vector_zero_vector:
"vector x ⟹ zero_vector x"
by (simp add: zero_vector_def vector_left_annihilator)
lemma vector_up_closed_zero_vector:
"vector x ⟷ up_closed x ∧ zero_vector x"
using up_closed_zero_vector_vector vector_up_closed vector_zero_vector by blast
lemma vector_zero_vector_one_vector:
"vector x ⟷ zero_vector x ∧ one_vector x"
by (simp add: co_vector_zero_vector_one_vector vector_co_vector)
end
text ‹M3-algebra›
context up_closed_multirelation_algebra
begin
lemma up_closed:
"up_closed x"
by (simp add: up_closed_def)
lemma dedekind_1_left:
"x * 1 ⊓ y ≤ (x ⊓ y * 1) * 1"
by simp
text ‹Theorem 10 / Figure 3: closure properties›
text ‹zero-vector›
lemma zero_vector_dual:
"zero_vector x ⟷ zero_vector (x⇧d)"
using up_closed_zero_vector_vector vector_dual vector_zero_vector up_closed by blast
end
text ‹complemented M0-algebra›
class lattice_ordered_pre_left_semiring_b = lattice_ordered_pre_left_semiring + complemented_distributive_lattice
begin
definition down_closed :: "'a ⇒ bool" where "down_closed x ≡ -x * 1 ≤ -x"
text ‹Theorem 10 / Figure 3: closure properties›
text ‹down-closed›
lemma zero_down_closed:
"down_closed bot"
by (simp add: down_closed_def)
lemma top_down_closed:
"down_closed top"
by (simp add: down_closed_def)
lemma complement_down_closed_up_closed:
"down_closed x ⟷ up_closed (-x)"
using down_closed_def order.antisym mult_sub_right_one up_closed_def by auto
lemma sup_down_closed:
"down_closed x ⟹ down_closed y ⟹ down_closed (x ⊔ y)"
by (simp add: complement_down_closed_up_closed inf_up_closed)
lemma inf_down_closed:
"down_closed x ⟹ down_closed y ⟹ down_closed (x ⊓ y)"
by (simp add: complement_down_closed_up_closed sup_up_closed)
end
class multirelation_algebra_1b = multirelation_algebra_1 + complemented_distributive_lattice
begin
subclass lattice_ordered_pre_left_semiring_b ..
text ‹Theorem 7.1›
lemma complement_mult_zero_sub:
"-(x * bot) ≤ -x * bot"
proof -
have "top = -x * bot ⊔ x * bot"
by (metis compl_sup_top mult_left_top mult_right_dist_sup)
thus ?thesis
by (simp add: heyting.implies_order sup.commute)
qed
text ‹Theorem 7.2›
lemma transitive_zero_vector_complement:
"transitive x ⟹ zero_vector (-x)"
by (meson complement_mult_zero_sub compl_mono mult_right_isotone order_trans zero_vector_def bot_least)
lemma transitive_dense_complement:
"transitive x ⟹ dense_rel (-x)"
by (simp add: zero_vector_dense transitive_zero_vector_complement)
lemma transitive_sup_distributive_complement:
"transitive x ⟹ sup_distributive (-x)"
by (simp add: zero_vector_sup_distributive transitive_zero_vector_complement)
lemma transitive_inf_distributive_complement:
"transitive x ⟹ inf_distributive (-x)"
by (simp add: zero_vector_inf_distributive transitive_zero_vector_complement)
lemma up_closed_zero_vector_complement:
"up_closed x ⟹ zero_vector (-x)"
by (meson complement_mult_zero_sub compl_le_swap2 one_vector_def order_trans up_closed_one_vector zero_vector_def)
lemma up_closed_dense_complement:
"up_closed x ⟹ dense_rel (-x)"
by (simp add: zero_vector_dense up_closed_zero_vector_complement)
lemma up_closed_sup_distributive_complement:
"up_closed x ⟹ sup_distributive (-x)"
by (simp add: zero_vector_sup_distributive up_closed_zero_vector_complement)
lemma up_closed_inf_distributive_complement:
"up_closed x ⟹ inf_distributive (-x)"
by (simp add: zero_vector_inf_distributive up_closed_zero_vector_complement)
text ‹Theorem 10 / Figure 3: closure properties›
text ‹closure under complement›
lemma co_total_total:
"co_total x ⟹ total (-x)"
by (metis complement_mult_zero_sub co_total_def compl_bot_eq mult_left_sub_dist_sup_right sup_bot_right top_le)
lemma complement_one_vector_zero_vector:
"one_vector x ⟹ zero_vector (-x)"
using compl_mono complement_mult_zero_sub one_vector_def order_trans zero_vector_def by blast
text ‹Theorem 6 / Figure 2: relations between properties›
lemma down_closed_zero_vector:
"down_closed x ⟹ zero_vector x"
using complement_down_closed_up_closed up_closed_zero_vector_complement by force
lemma down_closed_one_vector_vector:
"down_closed x ⟹ one_vector x ⟹ vector x"
by (simp add: down_closed_zero_vector zero_vector_one_vector_vector)
end
class multirelation_algebra_1c = multirelation_algebra_1b +
assumes dedekind_top_left: "x * top ⊓ y ≤ (x ⊓ y * top) * top"
assumes comp_zero_inf: "(x * bot ⊓ y) * bot ≤ (x ⊓ y) * bot"
begin
text ‹Theorem 7.3›
lemma schroeder_top_sub:
"-(x * top) * top ≤ -x"
proof -
have "-(x * top) * top ⊓ x ≤ bot"
by (metis dedekind_top_left p_inf zero_vector)
thus ?thesis
by (simp add: shunting_1)
qed
text ‹Theorem 7.4›
lemma schroeder_top:
"x * top ≤ y ⟷ -y * top ≤ -x"
apply (rule iffI)
using compl_mono inf.order_trans mult_left_isotone schroeder_top_sub apply blast
by (metis compl_mono double_compl mult_left_isotone order_trans schroeder_top_sub)
text ‹Theorem 7.5›
lemma schroeder_top_eq:
"-(x * top) * top = -(x * top)"
using vector_1 vector_mult_closed vector_top_closed schroeder_top by auto
lemma schroeder_one_eq:
"-(x * top) * 1 = -(x * top)"
by (metis top_mult_right_one schroeder_top_eq)
text ‹Theorem 7.6›
lemma vector_inf_comp:
"x * top ⊓ y * z = (x * top ⊓ y) * z"
proof (rule order.antisym)
have "x * top ⊓ y * z = x * top ⊓ ((x * top ⊓ y) ⊔ (-(x * top) ⊓ y)) * z"
by (simp add: inf_commute)
also have "... = x * top ⊓ ((x * top ⊓ y) * z ⊔ (-(x * top) ⊓ y) * z)"
by (simp add: inf_sup_distrib2 mult_right_dist_sup)
also have "... = (x * top ⊓ (x * top ⊓ y) * z) ⊔ (x * top ⊓ (-(x * top) ⊓ y) * z)"
by (simp add: inf_sup_distrib1)
also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ (-(x * top) ⊓ y) * z)"
by (simp add: le_infI2)
also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ -(x * top) * z)"
by (metis inf.sup_left_isotone inf_commute mult_right_sub_dist_inf_left sup_right_isotone)
also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ -(x * top) * top)"
using inf.sup_right_isotone mult_right_isotone sup_right_isotone by auto
also have "... = (x * top ⊓ y) * z"
by (simp add: schroeder_top_eq)
finally show "x * top ⊓ y * z ≤ (x * top ⊓ y) * z"
.
next
show "(x * top ⊓ y) * z ≤ x * top ⊓ y * z"
by (metis inf.bounded_iff mult_left_top mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right mult_semi_associative order_lesseq_imp)
qed
text ‹Theorem 7.7›
lemma vector_zero_inf_comp:
"(x * bot ⊓ y) * z = x * bot ⊓ y * z"
by (metis vector_inf_comp vector_mult_closed zero_vector)
lemma vector_zero_inf_comp_2:
"(x * bot ⊓ y) * z = (x * bot ⊓ y * 1) * z"
by (simp add: vector_zero_inf_comp)
text ‹Theorem 7.8›
lemma comp_zero_inf_2:
"x * bot ⊓ y * bot = (x ⊓ y) * bot"
using order.antisym mult_right_sub_dist_inf comp_zero_inf vector_zero_inf_comp by auto
lemma comp_zero_inf_3:
"x * bot ⊓ y * bot = (x * bot ⊓ y) * bot"
by (simp add: vector_zero_inf_comp)
lemma comp_zero_inf_4:
"x * bot ⊓ y * bot = (x * bot ⊓ y * bot) * bot"
by (metis comp_zero_inf_2 inf.commute vector_zero_inf_comp)
lemma comp_zero_inf_5:
"x * bot ⊓ y * bot = (x * 1 ⊓ y * 1) * bot"
by (metis comp_zero_inf_2 mult_one_associative)
lemma comp_zero_inf_6:
"x * bot ⊓ y * bot = (x * 1 ⊓ y * bot) * bot"
using inf.sup_monoid.add_commute vector_zero_inf_comp by fastforce
lemma comp_zero_inf_7:
"x * bot ⊓ y * bot = (x * 1 ⊓ y) * bot"
by (metis comp_zero_inf_2 mult_one_associative)
text ‹Theorem 10 / Figure 3: closure properties›
text ‹zero-vector›
lemma inf_zero_vector:
"zero_vector x ⟹ zero_vector y ⟹ zero_vector (x ⊓ y)"
by (metis comp_zero_inf_2 inf.sup_mono zero_vector_def)
text ‹down-closed›
lemma comp_down_closed:
"down_closed x ⟹ down_closed y ⟹ down_closed (x * y)"
by (metis complement_down_closed_up_closed down_closed_zero_vector up_closed_def zero_vector_0 schroeder_one_eq)
text ‹closure under complement›
lemma complement_vector:
"vector x ⟷ vector (-x)"
using vector_1 schroeder_top by blast
lemma complement_zero_vector_one_vector:
"zero_vector x ⟹ one_vector (-x)"
by (metis comp_zero_inf_2 order.antisym complement_mult_zero_sub double_compl inf.sup_monoid.add_commute mult_left_zero one_vector_def order.refl pseudo_complement top_right_mult_increasing zero_vector_0)
lemma complement_zero_vector_one_vector_iff:
"zero_vector x ⟷ one_vector (-x)"
using complement_zero_vector_one_vector complement_one_vector_zero_vector by force
lemma complement_one_vector_zero_vector_iff:
"one_vector x ⟷ zero_vector (-x)"
using complement_zero_vector_one_vector complement_one_vector_zero_vector by force
text ‹Theorem 6 / Figure 2: relations between properties›
lemma vector_down_closed:
"vector x ⟹ down_closed x"
using complement_vector complement_down_closed_up_closed vector_up_closed by blast
lemma co_vector_down_closed:
"co_vector x ⟹ down_closed x"
by (simp add: co_vector_vector vector_down_closed)
lemma vector_down_closed_one_vector:
"vector x ⟷ down_closed x ∧ one_vector x"
using down_closed_one_vector_vector up_closed_one_vector vector_up_closed vector_down_closed by blast
lemma vector_up_closed_down_closed:
"vector x ⟷ up_closed x ∧ down_closed x"
using down_closed_zero_vector up_closed_zero_vector_vector vector_up_closed vector_down_closed by blast
text ‹Section 7›
lemma vector_b1:
"vector x ⟷ -x * top = -x"
using complement_vector by auto
lemma vector_b2:
"vector x ⟷ -x * bot = -x"
by (metis down_closed_zero_vector vector_mult_closed zero_vector zero_vector_left_zero vector_b1 vector_down_closed)
lemma covector_b1:
"co_vector x ⟷ -x * top = -x"
using co_vector_def co_vector_vector vector_b1 vector_b2 by force
lemma covector_b2:
"co_vector x ⟷ -x * bot = -x"
using covector_b1 vector_b1 vector_b2 by auto
lemma vector_co_vector_iff:
"vector x ⟷ co_vector x"
by (simp add: covector_b2 vector_b2)
lemma zero_vector_b:
"zero_vector x ⟷ -x * bot ≤ -x"
by (simp add: complement_zero_vector_one_vector_iff one_vector_def)
lemma one_vector_b1:
"one_vector x ⟷ -x ≤ -x * bot"
by (simp add: complement_one_vector_zero_vector_iff zero_vector_def)
lemma one_vector_b0:
"one_vector x ⟷ (∀y z . -x * y = -x * z)"
by (simp add: complement_one_vector_zero_vector_iff zero_vector_0)
end
class multirelation_algebra_2b = multirelation_algebra_2 + complemented_distributive_lattice
begin
subclass multirelation_algebra_1b ..
end
text ‹complemented M1-algebra›
class multirelation_algebra_2c = multirelation_algebra_2b + multirelation_algebra_1c
class multirelation_algebra_3b = multirelation_algebra_3 + complemented_distributive_lattice
begin
subclass lattice_ordered_pre_left_semiring_b ..
lemma dual_complement_commute:
"-(x⇧d) = (-x)⇧d"
by (metis compl_unique dual_dist_sup dual_dist_inf dual_top dual_zero inf_complement sup_compl_top)
end
text ‹complemented M2-algebra›
class multirelation_algebra_5b = multirelation_algebra_5 + complemented_distributive_lattice
begin
subclass multirelation_algebra_2b ..
subclass multirelation_algebra_3b ..
lemma dual_down_closed:
"down_closed x ⟷ down_closed (x⇧d)"
using complement_down_closed_up_closed dual_complement_commute dual_up_closed by auto
end
class multirelation_algebra_5c = multirelation_algebra_5b + multirelation_algebra_1c
begin
lemma complement_mult_zero_below:
"-x * bot ≤ -(x * bot)"
by (simp add: comp_zero_inf_2 shunting_1)
end
class up_closed_multirelation_algebra_b = up_closed_multirelation_algebra + complemented_distributive_lattice
begin
subclass multirelation_algebra_5c
apply unfold_locales
apply (metis inf.sup_monoid.add_commute top_right_mult_increasing vector_inf_comp)
using mult_right_dist_inf vector_zero_inf_comp by auto
lemma complement_zero_vector:
"zero_vector x ⟷ zero_vector (-x)"
by (simp add: zero_right_mult_decreasing zero_vector_b)
lemma down_closed:
"down_closed x"
by (simp add: down_closed_def)
lemma vector:
"vector x"
by (simp add: down_closed up_closed_def vector_up_closed_down_closed)
end
end
Theory Binary_Iterings
section ‹Binary Iterings›
theory Binary_Iterings
imports Base
begin
class binary_itering = idempotent_left_zero_semiring + while +
assumes while_productstar: "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
assumes while_sumstar: "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
assumes while_left_dist_sup: "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
assumes while_sub_associative: "(x ⋆ y) * z ≤ x ⋆ (y * z)"
assumes while_simulate_left_plus: "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
assumes while_simulate_right_plus: "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
begin
text ‹Theorem 9.1›
lemma while_zero:
"bot ⋆ x = x"
by (metis sup_bot_right mult_left_zero while_productstar)
text ‹Theorem 9.4›
lemma while_mult_increasing:
"x * y ≤ x ⋆ y"
by (metis le_supI2 mult.left_neutral mult_left_sub_dist_sup_left while_productstar)
text ‹Theorem 9.2›
lemma while_one_increasing:
"x ≤ x ⋆ 1"
by (metis mult.right_neutral while_mult_increasing)
text ‹Theorem 9.3›
lemma while_increasing:
"y ≤ x ⋆ y"
by (metis sup_left_divisibility mult_left_one while_productstar)
text ‹Theorem 9.42›
lemma while_right_isotone:
"y ≤ z ⟹ x ⋆ y ≤ x ⋆ z"
by (metis le_iff_sup while_left_dist_sup)
text ‹Theorem 9.41›
lemma while_left_isotone:
"x ≤ y ⟹ x ⋆ z ≤ y ⋆ z"
using sup_left_divisibility while_sumstar while_increasing by auto
lemma while_isotone:
"w ≤ x ⟹ y ≤ z ⟹ w ⋆ y ≤ x ⋆ z"
by (meson order_lesseq_imp while_left_isotone while_right_isotone)
text ‹Theorem 9.17›
lemma while_left_unfold:
"x ⋆ y = y ⊔ x * (x ⋆ y)"
by (metis mult_1_left mult_1_right while_productstar)
lemma while_simulate_left_plus_1:
"x * z ≤ z * (y ⋆ 1) ⟹ x ⋆ (z * w) ≤ z * (y ⋆ w) ⊔ (x ⋆ bot)"
by (metis sup_bot_right mult_left_zero while_simulate_left_plus)
text ‹Theorem 11.1›
lemma while_simulate_absorb:
"y * x ≤ x ⟹ y ⋆ x ≤ x ⊔ (y ⋆ bot)"
by (metis while_simulate_left_plus_1 while_zero mult_1_right)
text ‹Theorem 9.10›
lemma while_transitive:
"x ⋆ (x ⋆ y) = x ⋆ y"
by (metis order.eq_iff sup_bot_right sup_ge2 while_left_dist_sup while_increasing while_left_unfold while_simulate_absorb)
text ‹Theorem 9.25›
lemma while_slide:
"(x * y) ⋆ (x * z) = x * ((y * x) ⋆ z)"
by (metis mult_left_dist_sup while_productstar mult_assoc while_left_unfold)
text ‹Theorem 9.21›
lemma while_zero_2:
"(x * bot) ⋆ y = x * bot ⊔ y"
by (metis mult_left_zero sup_commute mult_assoc while_left_unfold)
text ‹Theorem 9.5›
lemma while_mult_star_exchange:
"x * (x ⋆ y) = x ⋆ (x * y)"
by (metis mult_left_one while_slide)
text ‹Theorem 9.18›
lemma while_right_unfold:
"x ⋆ y = y ⊔ (x ⋆ (x * y))"
by (metis while_left_unfold while_mult_star_exchange)
text ‹Theorem 9.7›
lemma while_one_mult_below:
"(x ⋆ 1) * y ≤ x ⋆ y"
by (metis mult_left_one while_sub_associative)
lemma while_plus_one:
"x ⋆ y = y ⊔ (x ⋆ y)"
by (simp add: sup.absorb2 while_increasing)
text ‹Theorem 9.19›
lemma while_rtc_2:
"y ⊔ x * y ⊔ (x ⋆ (x ⋆ y)) = x ⋆ y"
by (simp add: sup_absorb2 while_increasing while_mult_increasing while_transitive)
text ‹Theorem 9.6›
lemma while_left_plus_below:
"x * (x ⋆ y) ≤ x ⋆ y"
by (metis sup_right_divisibility while_left_unfold)
lemma while_right_plus_below:
"x ⋆ (x * y) ≤ x ⋆ y"
using while_left_plus_below while_mult_star_exchange by auto
lemma while_right_plus_below_2:
"(x ⋆ x) * y ≤ x ⋆ y"
by (smt order_trans while_right_plus_below while_sub_associative)
text ‹Theorem 9.47›
lemma while_mult_transitive:
"x ≤ z ⋆ y ⟹ y ≤ z ⋆ w ⟹ x ≤ z ⋆ w"
by (smt order_trans while_right_isotone while_transitive)
text ‹Theorem 9.48›
lemma while_mult_upper_bound:
"x ≤ z ⋆ 1 ⟹ y ≤ z ⋆ w ⟹ x * y ≤ z ⋆ w"
by (metis order.trans mult_isotone while_one_mult_below while_transitive)
lemma while_one_mult_while_below:
"(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ v"
by (simp add: while_mult_upper_bound)
text ‹Theorem 9.34›
lemma while_sub_dist:
"x ⋆ z ≤ (x ⊔ y) ⋆ z"
by (simp add: while_left_isotone)
lemma while_sub_dist_1:
"x * z ≤ (x ⊔ y) ⋆ z"
using order.trans while_mult_increasing while_sub_dist by blast
lemma while_sub_dist_2:
"x * y * z ≤ (x ⊔ y) ⋆ z"
by (metis sup_commute mult_assoc while_mult_transitive while_sub_dist_1)
text ‹Theorem 9.36›
lemma while_sub_dist_3:
"x ⋆ (y ⋆ z) ≤ (x ⊔ y) ⋆ z"
by (metis sup_commute while_mult_transitive while_sub_dist)
text ‹Theorem 9.44›
lemma while_absorb_2:
"x ≤ y ⟹ y ⋆ (x ⋆ z) = y ⋆ z"
using sup_left_divisibility while_sumstar while_transitive by auto
lemma while_simulate_right_plus_1:
"z * x ≤ y * (y ⋆ z) ⟹ z * (x ⋆ w) ≤ y ⋆ (z * w)"
by (metis sup_bot_right mult_left_zero while_simulate_right_plus)
text ‹Theorem 9.39›
lemma while_sumstar_1_below:
"x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
proof -
have 1: "x * (((x ⋆ 1) * y) ⋆ (x ⋆ z)) ≤ ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
by (smt sup_mono sup_ge2 mult_assoc mult_left_dist_sup mult_right_sub_dist_sup_right while_left_unfold)
have "x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ (x ⋆ z) ⊔ (x ⋆ (y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
by (metis eq_refl while_left_dist_sup while_productstar)
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ ((x ⋆ 1) * y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
by (metis sup_right_isotone mult_assoc mult_left_one mult_right_sub_dist_sup_left while_left_unfold while_right_isotone)
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)))"
using semiring.add_left_mono while_left_plus_below while_right_isotone by blast
also have "... ≤ x ⋆ (((x ⋆ 1) * y) ⋆ (x ⋆ z))"
by (meson order.trans le_supI while_increasing while_one_mult_below while_right_isotone)
also have "... ≤ (((x ⋆ 1) * y) ⋆ (x ⋆ z)) ⊔ (x ⋆ bot)"
using 1 while_simulate_absorb by auto
also have "... = ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
by (smt sup_assoc sup_commute sup_bot_left while_left_dist_sup while_left_unfold)
finally show ?thesis
.
qed
lemma while_sumstar_2_below:
"((x ⋆ 1) * y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ (x ⋆ z)"
by (simp add: while_left_isotone while_one_mult_below)
text ‹Theorem 9.38›
lemma while_sup_1_below:
"x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ (x ⊔ y) ⋆ z"
proof -
have "((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z) ≤ (x ⊔ y) ⋆ z"
using while_sumstar while_isotone while_one_mult_below by auto
hence "(y * (x ⋆ 1)) ⋆ z ≤ z ⊔ y * ((x ⊔ y) ⋆ z)"
by (metis sup_right_isotone mult_right_isotone while_productstar)
also have "... ≤ (x ⊔ y) ⋆ z"
by (metis sup_right_isotone sup_ge2 mult_left_isotone while_left_unfold)
finally show ?thesis
using while_mult_transitive while_sub_dist by blast
qed
text ‹Theorem 9.16›
lemma while_while_while:
"((x ⋆ 1) ⋆ 1) ⋆ y = (x ⋆ 1) ⋆ y"
by (smt (z3) sup.absorb1 while_sumstar while_absorb_2 while_increasing while_one_increasing)
lemma while_one:
"(1 ⋆ 1) ⋆ y = 1 ⋆ y"
by (metis while_while_while while_zero)
text ‹Theorem 9.22›
lemma while_sup_below:
"x ⊔ y ≤ x ⋆ (y ⋆ 1)"
by (metis le_supI le_supI1 while_left_dist_sup while_left_unfold while_one_increasing)
text ‹Theorem 9.32›
lemma while_sup_2:
"(x ⊔ y) ⋆ z ≤ (x ⋆ (y ⋆ 1)) ⋆ z"
using while_left_isotone while_sup_below by auto
text ‹Theorem 9.45›
lemma while_sup_one_left_unfold:
"1 ≤ x ⟹ x * (x ⋆ y) = x ⋆ y"
by (metis order.antisym mult_1_left mult_left_isotone while_left_plus_below)
lemma while_sup_one_right_unfold:
"1 ≤ x ⟹ x ⋆ (x * y) = x ⋆ y"
using while_mult_star_exchange while_sup_one_left_unfold by auto
text ‹Theorem 9.30›
lemma while_decompose_7:
"(x ⊔ y) ⋆ z = x ⋆ (y ⋆ ((x ⊔ y) ⋆ z))"
by (metis order.eq_iff order_trans while_increasing while_sub_dist_3 while_transitive)
text ‹Theorem 9.31›
lemma while_decompose_8:
"(x ⊔ y) ⋆ z = (x ⊔ y) ⋆ (x ⋆ (y ⋆ z))"
using while_absorb_2 by auto
text ‹Theorem 9.27›
lemma while_decompose_9:
"(x ⋆ (y ⋆ 1)) ⋆ z = x ⋆ (y ⋆ ((x ⋆ (y ⋆ 1)) ⋆ z))"
by (smt sup_commute le_iff_sup order_trans while_sup_below while_increasing while_sub_dist_3)
lemma while_decompose_10:
"(x ⋆ (y ⋆ 1)) ⋆ z = (x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z))"
proof -
have 1: "(x ⋆ (y ⋆ 1)) ⋆ z ≤ (x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z))"
by (meson order.trans while_increasing while_right_isotone)
have "x ⊔ (y ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
using while_increasing while_sup_below by auto
hence "(x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z)) ≤ (x ⋆ (y ⋆ 1)) ⋆ z"
using while_absorb_2 while_sup_below by force
thus ?thesis
using 1 order.antisym by blast
qed
lemma while_back_loop_fixpoint:
"z * (y ⋆ (y * x)) ⊔ z * x = z * (y ⋆ x)"
by (metis sup_commute mult_left_dist_sup while_right_unfold)
lemma while_back_loop_prefixpoint:
"z * (y ⋆ 1) * y ⊔ z ≤ z * (y ⋆ 1)"
by (metis le_supI le_supI2 mult_1_right mult_right_isotone mult_assoc while_increasing while_one_mult_below while_right_unfold)
text ‹Theorem 9›
lemma while_loop_is_fixpoint:
"is_fixpoint (λx . y * x ⊔ z) (y ⋆ z)"
using is_fixpoint_def sup_commute while_left_unfold by auto
text ‹Theorem 9›
lemma while_back_loop_is_prefixpoint:
"is_prefixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))"
using is_prefixpoint_def while_back_loop_prefixpoint by auto
text ‹Theorem 9.20›
lemma while_while_sup:
"(1 ⊔ x) ⋆ y = (x ⋆ 1) ⋆ y"
by (metis sup_commute while_decompose_10 while_sumstar while_zero)
lemma while_while_mult_sub:
"x ⋆ (1 ⋆ y) ≤ (x ⋆ 1) ⋆ y"
by (metis sup_commute while_sub_dist_3 while_while_sup)
text ‹Theorem 9.11›
lemma while_right_plus:
"(x ⋆ x) ⋆ y = x ⋆ y"
by (metis sup_idem while_plus_one while_sumstar while_transitive)
text ‹Theorem 9.12›
lemma while_left_plus:
"(x * (x ⋆ 1)) ⋆ y = x ⋆ y"
by (simp add: while_mult_star_exchange while_right_plus)
text ‹Theorem 9.9›
lemma while_below_while_one:
"x ⋆ x ≤ x ⋆ 1"
by (meson eq_refl while_mult_transitive while_one_increasing)
lemma while_below_while_one_mult:
"x * (x ⋆ x) ≤ x * (x ⋆ 1)"
by (simp add: mult_right_isotone while_below_while_one)
text ‹Theorem 9.23›
lemma while_sup_sub_sup_one:
"x ⋆ (x ⊔ y) ≤ x ⋆ (1 ⊔ y)"
using semiring.add_right_mono while_left_dist_sup while_below_while_one by auto
lemma while_sup_sub_sup_one_mult:
"x * (x ⋆ (x ⊔ y)) ≤ x * (x ⋆ (1 ⊔ y))"
by (simp add: mult_right_isotone while_sup_sub_sup_one)
lemma while_elimination:
"x * y = bot ⟹ x * (y ⋆ z) = x * z"
by (metis sup_bot_right mult_assoc mult_left_dist_sup mult_left_zero while_left_unfold)
text ‹Theorem 9.8›
lemma while_square:
"(x * x) ⋆ y ≤ x ⋆ y"
by (metis while_left_isotone while_mult_increasing while_right_plus)
text ‹Theorem 9.35›
lemma while_mult_sub_sup:
"(x * y) ⋆ z ≤ (x ⊔ y) ⋆ z"
by (metis while_increasing while_isotone while_mult_increasing while_sumstar)
text ‹Theorem 9.43›
lemma while_absorb_1:
"x ≤ y ⟹ x ⋆ (y ⋆ z) = y ⋆ z"
by (metis order.antisym le_iff_sup while_increasing while_sub_dist_3)
lemma while_absorb_3:
"x ≤ y ⟹ x ⋆ (y ⋆ z) = y ⋆ (x ⋆ z)"
by (simp add: while_absorb_1 while_absorb_2)
text ‹Theorem 9.24›
lemma while_square_2:
"(x * x) ⋆ ((x ⊔ 1) * y) ≤ x ⋆ y"
by (metis le_supI while_increasing while_mult_transitive while_mult_upper_bound while_one_increasing while_square)
lemma while_separate_unfold_below:
"(y * (x ⋆ 1)) ⋆ z ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
proof -
have "(y * (x ⋆ 1)) ⋆ z = (y ⋆ (y * x * (x ⋆ 1))) ⋆ (y ⋆ z)"
by (metis mult_assoc mult_left_dist_sup mult_1_right while_left_unfold while_sumstar)
hence "(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ 1))) * ((y * (x ⋆ 1)) ⋆ z)"
using while_left_unfold by auto
also have "... ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ 1)) * ((y * (x ⋆ 1)) ⋆ z))"
using sup_right_isotone while_sub_associative by auto
also have "... ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
by (smt sup_right_isotone mult_assoc mult_right_isotone while_one_mult_below while_right_isotone)
finally show ?thesis
.
qed
text ‹Theorem 9.33›
lemma while_mult_zero_sup:
"(x ⊔ y * bot) ⋆ z = x ⋆ ((y * bot) ⋆ z)"
proof -
have "(x ⊔ y * bot) ⋆ z = (x ⋆ (y * bot)) ⋆ (x ⋆ z)"
by (simp add: while_sumstar)
also have "... = (x ⋆ z) ⊔ (x ⋆ (y * bot)) * ((x ⋆ (y * bot)) ⋆ (x ⋆ z))"
using while_left_unfold by auto
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (y * bot))"
by (metis sup_right_isotone mult_assoc mult_left_zero while_sub_associative)
also have "... = x ⋆ ((y * bot) ⋆ z)"
by (simp add: sup_commute while_left_dist_sup while_zero_2)
finally show ?thesis
by (simp add: order.antisym while_sub_dist_3)
qed
lemma while_sup_mult_zero:
"(x ⊔ y * bot) ⋆ y = x ⋆ y"
by (simp add: sup_absorb2 zero_right_mult_decreasing while_mult_zero_sup while_zero_2)
lemma while_mult_zero_sup_2:
"(x ⊔ y * bot) ⋆ z = (x ⋆ z) ⊔ (x ⋆ (y * bot))"
by (simp add: sup_commute while_left_dist_sup while_mult_zero_sup while_zero_2)
lemma while_sup_zero_star:
"(x ⊔ y * bot) ⋆ z = x ⋆ (y * bot ⊔ z)"
by (simp add: while_mult_zero_sup while_zero_2)
lemma while_unfold_sum:
"(x ⊔ y) ⋆ z = (x ⋆ z) ⊔ (x ⋆ (y * ((x ⊔ y) ⋆ z)))"
apply (rule order.antisym)
apply (metis semiring.add_left_mono while_sub_associative while_sumstar while_left_unfold)
by (metis le_supI while_decompose_7 while_mult_increasing while_right_isotone while_sub_dist)
lemma while_simulate_left:
"x * z ≤ z * y ⊔ w ⟹ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
by (metis sup_left_isotone mult_right_isotone order_trans while_one_increasing while_simulate_left_plus)
lemma while_simulate_right:
assumes "z * x ≤ y * z ⊔ w"
shows "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
proof -
have "y * z ⊔ w ≤ y * (y ⋆ z) ⊔ w"
using sup_left_isotone while_increasing while_mult_star_exchange by force
thus ?thesis
by (meson assms order.trans while_simulate_right_plus)
qed
lemma while_simulate:
"z * x ≤ y * z ⟹ z * (x ⋆ v) ≤ y ⋆ (z * v)"
by (metis sup_bot_right mult_left_zero while_simulate_right)
text ‹Theorem 9.14›
lemma while_while_mult:
"1 ⋆ (x ⋆ y) = (x ⋆ 1) ⋆ y"
proof -
have "(x ⋆ 1) ⋆ y ≤ (x ⋆ 1) * ((x ⋆ 1) ⋆ y)"
by (simp add: while_increasing while_sup_one_left_unfold)
also have "... ≤ 1 ⋆ ((x ⋆ 1) * y)"
by (simp add: while_one_mult_while_below while_simulate)
also have "... ≤ 1 ⋆ (x ⋆ y)"
by (simp add: while_isotone while_one_mult_below)
finally show ?thesis
by (metis order.antisym while_sub_dist_3 while_while_sup)
qed
lemma while_simulate_left_1:
"x * z ≤ z * y ⟹ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ bot)"
by (meson order.trans mult_right_isotone while_one_increasing while_simulate_left_plus_1)
text ‹Theorem 9.46›
lemma while_associative_1:
assumes "1 ≤ z"
shows "x ⋆ (y * z) = (x ⋆ y) * z"
proof -
have "x ⋆ (y * z) ≤ x ⋆ ((x ⋆ y) * z)"
by (simp add: mult_isotone while_increasing while_right_isotone)
also have "... ≤ (x ⋆ y) * (bot ⋆ z) ⊔ (x ⋆ bot)"
by (metis mult_assoc mult_right_sub_dist_sup_right while_left_unfold while_simulate_absorb while_zero)
also have "... ≤ (x ⋆ y) * z ⊔ (x ⋆ bot) * z"
by (metis assms le_supI sup_ge1 sup_ge2 case_split_right while_plus_one while_zero)
also have "... = (x ⋆ y) * z"
by (metis sup_bot_right mult_right_dist_sup while_left_dist_sup)
finally show ?thesis
by (simp add: order.antisym while_sub_associative)
qed
text ‹Theorem 9.29›
lemma while_associative_while_1:
"x ⋆ (y * (z ⋆ 1)) = (x ⋆ y) * (z ⋆ 1)"
by (simp add: while_associative_1 while_increasing)
text ‹Theorem 9.13›
lemma while_one_while:
"(x ⋆ 1) * (y ⋆ 1) = x ⋆ (y ⋆ 1)"
by (metis mult_left_one while_associative_while_1)
lemma while_decompose_5_below:
"(x ⋆ (y ⋆ 1)) ⋆ z ≤ (y ⋆ (x ⋆ 1)) ⋆ z"
by (smt (z3) while_left_dist_sup while_sumstar while_absorb_2 while_one_increasing while_plus_one while_sub_dist)
text ‹Theorem 9.26›
lemma while_decompose_5:
"(x ⋆ (y ⋆ 1)) ⋆ z = (y ⋆ (x ⋆ 1)) ⋆ z"
by (simp add: order.antisym while_decompose_5_below)
lemma while_decompose_4:
"(x ⋆ (y ⋆ 1)) ⋆ z = x ⋆ ((y ⋆ (x ⋆ 1)) ⋆ z)"
using while_absorb_1 while_decompose_5 while_sup_below by auto
text ‹Theorem 11.7›
lemma while_simulate_2:
"y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟷ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
proof
assume "y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
hence "y * (x ⋆ 1) ≤ (x ⋆ 1) * (y ⋆ 1)"
by (simp add: while_one_while)
hence "y ⋆ ((x ⋆ 1) * 1) ≤ (x ⋆ 1) * (y ⋆ 1) ⊔ (y ⋆ bot)"
using while_simulate_left_plus_1 by blast
hence "y ⋆ (x ⋆ 1) ≤ (x ⋆ (y ⋆ 1)) ⊔ (y ⋆ bot)"
by (simp add: while_one_while)
also have "... = x ⋆ (y ⋆ 1)"
by (metis sup_commute le_iff_sup order_trans while_increasing while_right_isotone bot_least)
finally show "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
.
next
assume "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
thus "y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
using order_trans while_mult_increasing by blast
qed
lemma while_simulate_1:
"y * x ≤ x * y ⟹ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
by (metis order_trans while_mult_increasing while_right_isotone while_simulate while_simulate_2)
lemma while_simulate_3:
"y * (x ⋆ 1) ≤ x ⋆ 1 ⟹ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
by (meson order.trans while_increasing while_right_isotone while_simulate_2)
text ‹Theorem 9.28›
while_extra_while:
"(y * (x ⋆ 1)) ⋆ z = (y * (y ⋆ (x ⋆ 1))) ⋆ z"
proof -
have "y * (y ⋆ (x ⋆ 1)) ≤ y * (x ⋆ 1) * (y * (x ⋆ 1) ⋆ 1)"
using while_back_loop_prefixpoint while_left_isotone while_mult_star_exchange by auto
hence 1: "(y * (y ⋆ (x ⋆ 1))) ⋆ z ≤ (y * (x ⋆ 1)) ⋆ z"
by (metis while_simulate_right_plus_1 mult_left_one)
have "(y * (x ⋆ 1)) ⋆ z ≤ (y * (y ⋆ (x ⋆ 1))) ⋆ z"
by (simp add: while_increasing while_left_isotone while_mult_star_exchange)
thus ?thesis
using 1 order.antisym by auto
qed
text ‹Theorem 11.6›
lemma while_separate_4:
assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
shows "(x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
proof -
have "(1 ⊔ y) * x ≤ x * (x ⋆ (1 ⊔ y))"
by (smt assms sup_assoc le_supI mult_left_one mult_left_sub_dist_sup_left mult_right_dist_sup mult_1_right while_left_unfold)
hence 1: "(1 ⊔ y) * (x ⋆ 1) ≤ x ⋆ (1 ⊔ y)"
by (metis mult_1_right while_simulate_right_plus_1)
have "y * x * (x ⋆ 1) ≤ x * (x ⋆ ((1 ⊔ y) * (x ⋆ 1)))"
by (smt assms le_iff_sup mult_assoc mult_right_dist_sup while_associative_1 while_increasing)
also have "... ≤ x * (x ⋆ (1 ⊔ y))"
using 1 mult_right_isotone while_mult_transitive by blast
also have "... ≤ x * (x ⋆ 1) * (y ⋆ 1)"
by (simp add: mult_right_isotone mult_assoc while_increasing while_one_increasing while_one_while while_right_isotone)
finally have "y ⋆ (x * (x ⋆ 1)) ≤ x * (x ⋆ 1) * (y ⋆ 1) ⊔ (y ⋆ bot)"
by (metis mult_assoc mult_1_right while_simulate_left_plus_1)
hence "(y ⋆ 1) * (y ⋆ x) ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
by (smt le_iff_sup mult_assoc mult_1_right order_refl order_trans while_absorb_2 while_left_dist_sup while_mult_star_exchange while_one_mult_below while_one_while while_plus_one)
hence "(y ⋆ 1) * ((y ⋆ x) ⋆ (y ⋆ z)) ≤ x ⋆ ((y ⋆ 1) * (y ⋆ z) ⊔ (y ⋆ bot) * ((y ⋆ x) ⋆ (y ⋆ z)))"
by (simp add: while_simulate_right_plus)
also have "... ≤ x ⋆ ((y ⋆ z) ⊔ (y ⋆ bot))"
by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
also have "... = x ⋆ y ⋆ z"
using sup.absorb_iff1 while_right_isotone by auto
finally show ?thesis
by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed
lemma while_separate_5:
"y * x ≤ x * (x ⋆ (x ⊔ y)) ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
using order_lesseq_imp while_separate_4 while_sup_sub_sup_one_mult by blast
lemma while_separate_6:
"y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
by (smt order_trans while_increasing while_mult_star_exchange while_separate_5)
text ‹Theorem 11.4›
lemma while_separate_1:
"y * x ≤ x * y ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
using mult_left_sub_dist_sup_right order_lesseq_imp while_separate_6 by blast
text ‹Theorem 11.2›
lemma while_separate_mult_1:
"y * x ≤ x * y ⟹ (x * y) ⋆ z ≤ x ⋆ (y ⋆ z)"
by (metis while_mult_sub_sup while_separate_1)
text ‹Theorem 11.5›
lemma separation:
assumes "y * x ≤ x * (y ⋆ 1)"
shows "(x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
proof -
have "y ⋆ x ≤ x * (y ⋆ 1) ⊔ (y ⋆ bot)"
by (metis assms mult_1_right while_simulate_left_plus_1)
also have "... ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
using sup_left_isotone while_increasing while_mult_star_exchange by force
finally have "(y ⋆ 1) * (y ⋆ x) ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
using order.trans while_one_mult_while_below by blast
hence "(y ⋆ 1) * ((y ⋆ x) ⋆ (y ⋆ z)) ≤ x ⋆ ((y ⋆ 1) * (y ⋆ z) ⊔ (y ⋆ bot) * ((y ⋆ x) ⋆ (y ⋆ z)))"
by (simp add: while_simulate_right_plus)
also have "... ≤ x ⋆ ((y ⋆ z) ⊔ (y ⋆ bot))"
by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
also have "... = x ⋆ y ⋆ z"
using sup.absorb_iff1 while_right_isotone by auto
finally show ?thesis
by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed
text ‹Theorem 11.5›
lemma while_separate_left:
"y * x ≤ x * (y ⋆ 1) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
by (metis sup_commute separation while_sub_dist_3)
text ‹Theorem 11.6›
lemma while_simulate_4:
"y * x ≤ x * (x ⋆ (1 ⊔ y)) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
by (metis sup_commute while_separate_4 while_sub_dist_3)
lemma while_simulate_5:
"y * x ≤ x * (x ⋆ (x ⊔ y)) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
by (smt order_trans while_sup_sub_sup_one_mult while_simulate_4)
lemma while_simulate_6:
"y * x ≤ x * (x ⊔ y) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
by (smt order_trans while_increasing while_mult_star_exchange while_simulate_5)
text ‹Theorem 11.3›
lemma while_simulate_7:
"y * x ≤ x * y ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
using mult_left_sub_dist_sup_right order_lesseq_imp while_simulate_6 by blast
lemma while_while_mult_1:
"x ⋆ (1 ⋆ y) = 1 ⋆ (x ⋆ y)"
by (metis sup_commute mult_left_one mult_1_right order_refl while_separate_1)
text ‹Theorem 9.15›
lemma while_while_mult_2:
"x ⋆ (1 ⋆ y) = (x ⋆ 1) ⋆ y"
by (simp add: while_while_mult while_while_mult_1)
text ‹Theorem 11.8›
lemma while_import:
assumes "p ≤ p * p ∧ p ≤ 1 ∧ p * x ≤ x * p"
shows "p * (x ⋆ y) = p * ((p * x) ⋆ y)"
proof -
have "p * (x ⋆ y) ≤ (p * x) ⋆ (p * y)"
using assms test_preserves_equation while_simulate by auto
also have "... ≤ (p * x) ⋆ y"
by (metis assms le_iff_sup mult_left_one mult_right_dist_sup while_right_isotone)
finally have 2: "p * (x ⋆ y) ≤ p * ((p * x) ⋆ y)"
by (smt assms sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_1_right)
have "p * ((p * x) ⋆ y) ≤ p * (x ⋆ y)"
by (metis assms mult_left_isotone mult_left_one mult_right_isotone while_left_isotone)
thus ?thesis
using 2 order.antisym by auto
qed
text ‹Theorem 11.8›
lemma while_preserve:
assumes "p ≤ p * p"
and "p ≤ 1"
and "p * x ≤ x * p"
shows "p * (x ⋆ y) = p * (x ⋆ (p * y))"
proof (rule order.antisym)
show "p * (x ⋆ y) ≤ p * (x ⋆ (p * y))"
by (metis assms order.antisym coreflexive_transitive mult_right_isotone mult_assoc while_simulate)
show "p * (x ⋆ (p * y)) ≤ p * (x ⋆ y)"
by (metis assms(2) mult_left_isotone mult_left_one mult_right_isotone while_right_isotone)
qed
lemma while_plus_below_while:
"(x ⋆ 1) * x ≤ x ⋆ 1"
by (simp add: while_mult_upper_bound while_one_increasing)
text ‹Theorem 9.40›
lemma while_01:
"(w * (x ⋆ 1)) ⋆ (y * z) ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
have "(w * (x ⋆ 1)) ⋆ (y * z) = y * z ⊔ w * (((x ⋆ 1) * w) ⋆ ((x ⋆ 1) * y * z))"
by (metis mult_assoc while_productstar)
also have "... ≤ y * z ⊔ w * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
by (metis sup_right_isotone mult_left_isotone mult_right_isotone while_isotone while_one_mult_below)
also have "... ≤ (x ⋆ y) * z ⊔ (x ⋆ w) * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
by (meson mult_left_isotone semiring.add_mono while_increasing)
finally show ?thesis
using while_left_unfold by auto
qed
text ‹Theorem 9.37›
lemma while_while_sub_associative:
"x ⋆ (y ⋆ z) ≤ ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
proof -
have 1: "x * (x ⋆ 1) ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ 1)"
by (metis le_supE while_back_loop_prefixpoint while_mult_increasing while_mult_transitive while_one_while)
have "x ⋆ (y ⋆ z) ≤ x ⋆ ((x ⋆ 1) * (y ⋆ z))"
by (metis mult_left_isotone mult_left_one while_increasing while_right_isotone)
also have "... ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ (y ⋆ z)) ⊔ (x ⋆ bot)"
using 1 while_simulate_left_plus_1 by auto
also have "... ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
by (simp add: le_supI1 sup_commute while_absorb_2 while_increasing while_right_isotone)
also have "... = (x ⋆ 1) * z ⊔ (x ⋆ 1) * (x ⋆ y) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
by (metis mult_assoc mult_left_dist_sup while_left_unfold)
also have "... = (x ⋆ y) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
by (smt sup_assoc sup_commute le_iff_sup mult_left_one mult_right_dist_sup order_refl while_absorb_1 while_plus_one while_sub_associative)
also have "... ≤ ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
using sup_left_isotone while_left_plus_below by auto
finally show ?thesis
.
qed
lemma while_induct:
"x * z ≤ z ∧ y ≤ z ∧ x ⋆ 1 ≤ z ⟹ x ⋆ y ≤ z"
by (metis le_supI1 sup_commute sup_bot_left le_iff_sup while_right_isotone while_simulate_absorb)
end
class bounded_binary_itering = bounded_idempotent_left_zero_semiring + binary_itering
begin
text ‹Theorem 9›
lemma while_right_top:
"x ⋆ top = top"
by (metis sup_left_top while_left_unfold)
text ‹Theorem 9›
lemma while_left_top:
"top * (x ⋆ 1) = top"
by (meson order.antisym le_supE top_greatest while_back_loop_prefixpoint)
end
class extended_binary_itering = binary_itering +
assumes while_denest_0: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)"
begin
text ‹Theorem 10.2›
lemma while_denest_1:
"w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ z"
using while_denest_0 while_mult_increasing while_mult_transitive by blast
lemma while_mult_sub_while_while:
"x ⋆ (y * z) ≤ (x ⋆ y) ⋆ z"
by (metis mult_left_one while_denest_1)
lemma while_zero_zero:
"(x ⋆ bot) ⋆ bot = x ⋆ bot"
by (metis order.antisym mult_left_zero sup_bot_left while_left_unfold while_sub_associative while_mult_sub_while_while)
text ‹Theorem 10.11›
lemma while_mult_zero_zero:
"(x * (y ⋆ bot)) ⋆ bot = x * (y ⋆ bot)"
apply (rule order.antisym)
apply (metis sup_bot_left while_left_unfold mult_assoc le_supI1 mult_left_zero mult_right_isotone while_left_dist_sup while_sub_associative)
by (metis mult_left_zero while_denest_1)
text ‹Theorem 10.3›
lemma while_denest_2:
"w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)"
apply (rule order.antisym)
apply (metis mult_assoc while_denest_0 while_simulate_right_plus_1 while_slide)
by (simp add: mult_isotone while_left_isotone while_sub_associative)
text ‹Theorem 10.12›
lemma while_denest_3:
"(x ⋆ w) ⋆ (x ⋆ bot) = (x ⋆ w) ⋆ bot"
by (metis while_absorb_2 while_right_isotone while_zero_zero bot_least)
text ‹Theorem 10.15›
lemma while_02:
"x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
have "x * ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = x * (x ⋆ y) * z ⊔ x * (x ⋆ w) * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
by (metis mult_assoc mult_left_dist_sup while_left_unfold)
also have "... ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
by (metis sup_mono mult_right_sub_dist_sup_right while_left_unfold)
finally have "x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) ≤ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) ⊔ (x ⋆ bot)"
using while_simulate_absorb by auto
also have "... = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
by (metis sup_commute le_iff_sup order_trans while_mult_sub_while_while while_right_isotone bot_least)
finally show ?thesis
by (simp add: order.antisym while_increasing)
qed
lemma while_sumstar_3_below:
"(x ⋆ y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
proof -
have "(x ⋆ y) ⋆ (x ⋆ z) = (x ⋆ z) ⊔ ((x ⋆ y) ⋆ ((x ⋆ y) * (x ⋆ z)))"
using while_right_unfold by blast
also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ (y * (x ⋆ z))))"
by (meson sup_right_isotone while_right_isotone while_sub_associative)
also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ ((x ⋆ y) ⋆ (x ⋆ z))))"
by (smt sup_right_isotone order_trans while_increasing while_mult_upper_bound while_one_increasing while_right_isotone)
also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ ((x ⋆ y) ⋆ ((x ⋆ 1) * z))))"
by (metis sup_right_isotone mult_left_isotone mult_left_one order_trans while_increasing while_right_isotone while_sumstar while_transitive)
also have "... = (x ⋆ z) ⊔ ((x ⋆ y) ⋆ ((x ⋆ 1) * z))"
by (simp add: while_transitive while_02)
also have "... = (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
by (smt sup_assoc mult_left_one mult_right_dist_sup while_02 while_left_dist_sup while_plus_one)
finally show ?thesis
.
qed
lemma while_sumstar_4_below:
"(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
proof -
have "(x ⋆ y) ⋆ ((x ⋆ 1) * z) = (x ⋆ 1) * z ⊔ (x ⋆ y) * ((x ⋆ y) ⋆ ((x ⋆ 1) * z))"
using while_left_unfold by auto
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (y * ((x ⋆ y) ⋆ ((x ⋆ 1) * z))))"
by (meson sup_mono while_one_mult_below while_sub_associative)
also have "... = (x ⋆ z) ⊔ (x ⋆ (y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
by (metis mult_left_one while_denest_2)
also have "... = x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
by (metis while_left_dist_sup while_productstar)
finally show ?thesis
.
qed
text ‹Theorem 10.10›
lemma while_sumstar_1:
"(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
by (smt order.eq_iff order_trans while_sup_1_below while_sumstar while_sumstar_3_below while_sumstar_4_below)
text ‹Theorem 10.8›
lemma while_sumstar_2:
"(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
using order.antisym while_sup_1_below while_sumstar_1 while_sumstar_4_below by auto
text ‹Theorem 10.9›
lemma while_sumstar_3:
"(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
using order.antisym while_sumstar while_sumstar_1_below while_sumstar_2_below while_sumstar_2 by force
text ‹Theorem 10.6›
lemma while_decompose_6:
"x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)"
by (metis sup_commute while_sumstar_2)
text ‹Theorem 10.4›
lemma while_denest_4:
"(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
have "(x ⋆ w) ⋆ (x ⋆ (y * z)) = x ⋆ ((w * (x ⋆ 1)) ⋆ (y * z))"
using while_sumstar while_sumstar_2 by force
also have "... ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
by (metis while_01 while_right_isotone while_02)
finally show ?thesis
using order.antisym while_right_isotone while_sub_associative by auto
qed
text ‹Theorem 10.13›
lemma while_denest_5:
"w * ((x ⋆ (y * w)) ⋆ (x ⋆ (y * z))) = w * (((x ⋆ y) * w) ⋆ ((x ⋆ y) * z))"
by (simp add: while_denest_2 while_denest_4)
text ‹Theorem 10.5›
lemma while_denest_6:
"(w * (x ⋆ y)) ⋆ z = z ⊔ w * ((x ⊔ y * w) ⋆ (y * z))"
by (metis while_denest_5 while_productstar while_sumstar)
text ‹Theorem 10.1›
lemma while_sum_below_one:
"y * ((x ⊔ y) ⋆ z) ≤ (y * (x ⋆ 1)) ⋆ z"
by (simp add: while_denest_6)
text ‹Theorem 10.14›
lemma while_separate_unfold:
"(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
proof -
have "y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))) ≤ y ⋆ (y * ((x ⊔ y) ⋆ z))"
using mult_right_isotone while_left_plus_below while_right_isotone mult_assoc while_sumstar_2 by auto
also have "... ≤ (y * (x ⋆ 1)) ⋆ z"
by (metis sup_commute sup_ge1 while_absorb_1 while_mult_star_exchange while_sum_below_one)
finally have "(y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z)))) ≤ (y * (x ⋆ 1)) ⋆ z"
using sup.bounded_iff while_back_loop_prefixpoint while_left_isotone by auto
thus ?thesis
by (simp add: order.antisym while_separate_unfold_below)
qed
text ‹Theorem 10.7›
lemma while_finite_associative:
"x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
by (metis while_denest_4 while_zero)
text ‹Theorem 12›
lemma atomicity_refinement:
assumes "s = s * q"
and "x = q * x"
and "q * b = bot"
and "r * b ≤ b * r"
and "r * l ≤ l * r"
and "x * l ≤ l * x"
and "b * l ≤ l * b"
and "q * l ≤ l * q"
and "r ⋆ q ≤ q * (r ⋆ 1) ∧ q ≤ 1"
shows "s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)"
proof -
have 1: "(x ⊔ b ⊔ r) * l ≤ l * (x ⊔ b ⊔ r)"
by (smt assms(5-7) mult_left_dist_sup semiring.add_mono semiring.distrib_right)
have "q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z) ≤ (x * (b ⋆ r ⋆ 1) * q) ⋆ z"
using assms(9) order_lesseq_imp while_increasing while_mult_upper_bound by blast
also have "... ≤ (x * (b ⋆ ((r ⋆ 1) * q))) ⋆ z"
by (simp add: mult_right_isotone while_left_isotone while_sub_associative mult_assoc)
also have "... ≤ (x * (b ⋆ r ⋆ q)) ⋆ z"
by (simp add: mult_right_isotone while_left_isotone while_one_mult_below while_right_isotone)
also have "... ≤ (x * (b ⋆ (q * (r ⋆ 1)))) ⋆ z"
by (simp add: assms(9) mult_right_isotone while_left_isotone while_right_isotone)
finally have 2: "q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z) ≤ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z"
using while_associative_while_1 mult_assoc by auto
have "s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) = s * (l ⋆ (x ⊔ b ⊔ r) ⋆ (q * z))"
using 1 sup_commute while_separate_1 by fastforce
also have "... = s * q * (l ⋆ b ⋆ r ⋆ (q * x * (b ⋆ r ⋆ 1)) ⋆ (q * z))"
by (smt assms(1,2,4) sup_assoc sup_commute while_sumstar_2 while_separate_1)
also have "... = s * q * (l ⋆ b ⋆ r ⋆ (q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z)))"
by (simp add: while_slide mult_assoc)
also have "... ≤ s * q * (l ⋆ b ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z)"
using 2 by (meson mult_right_isotone while_right_isotone)
also have "... ≤ s * (l ⋆ q * (b ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z))"
by (simp add: assms(8) mult_right_isotone while_simulate mult_assoc)
also have "... = s * (l ⋆ q * (r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z))"
using assms(3) while_elimination by auto
also have "... ≤ s * (l ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z)"
by (meson assms(9) order.trans mult_right_isotone order.refl while_increasing while_mult_upper_bound while_right_isotone)
also have "... = s * (l ⋆ (r ⊔ x * (b ⋆ q)) ⋆ z)"
by (simp add: while_sumstar_2)
also have "... ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)"
using mult_right_isotone sup_commute while_sub_dist_3 by auto
finally show ?thesis
.
qed
end
class bounded_extended_binary_itering = bounded_binary_itering + extended_binary_itering
end
Theory Binary_Iterings_Strict
section ‹Strict Binary Iterings›
theory Binary_Iterings_Strict
imports Stone_Kleene_Relation_Algebras.Iterings Binary_Iterings
begin
class strict_itering = itering + while +
assumes while_def: "x ⋆ y = x⇧∘ * y"
begin
text ‹Theorem 8.1›
subclass extended_binary_itering
apply unfold_locales
apply (metis circ_loop_fixpoint circ_slide_1 sup_commute while_def mult_assoc)
apply (metis circ_sup mult_assoc while_def)
apply (simp add: mult_left_dist_sup while_def)
apply (simp add: while_def mult_assoc)
apply (metis circ_simulate_left_plus mult_assoc mult_left_isotone mult_right_dist_sup mult_1_right while_def)
apply (metis circ_simulate_right_plus mult_assoc mult_left_isotone mult_right_dist_sup while_def)
by (metis circ_loop_fixpoint mult_right_sub_dist_sup_right while_def mult_assoc)
text ‹Theorem 13.1›
lemma while_associative:
"(x ⋆ y) * z = x ⋆ (y * z)"
by (simp add: while_def mult_assoc)
text ‹Theorem 13.3›
lemma while_one_mult:
"(x ⋆ 1) * x = x ⋆ x"
by (simp add: while_def)
lemma while_back_loop_is_fixpoint:
"is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))"
by (simp add: circ_back_loop_is_fixpoint while_def)
text ‹Theorem 13.4›
lemma while_sumstar_var:
"(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)"
by (simp add: while_sumstar_3 while_associative)
text ‹Theorem 13.2›
lemma while_mult_1_assoc:
"(x ⋆ 1) * y = x ⋆ y"
by (simp add: while_def)
end
class bounded_strict_itering = bounded_itering + strict_itering
begin
subclass bounded_extended_binary_itering ..
text ‹Theorem 13.6›
lemma while_top_2:
"top ⋆ z = top * z"
by (simp add: circ_top while_def)
text ‹Theorem 13.5›
lemma while_mult_top_2:
"(x * top) ⋆ z = z ⊔ x * top * z"
by (metis circ_left_top mult_assoc while_def while_left_unfold)
text ‹Theorem 13 counterexamples›
end
class binary_itering_unary = extended_binary_itering + circ +
assumes circ_def: "x⇧∘ = x ⋆ 1"
begin
text ‹Theorem 50.7›
subclass left_conway_semiring
apply unfold_locales
using circ_def while_left_unfold apply simp
apply (metis circ_def mult_1_right while_one_mult_below while_slide)
using circ_def while_one_while while_sumstar_2 by auto
end
class strict_binary_itering = binary_itering + circ +
assumes while_associative: "(x ⋆ y) * z = x ⋆ (y * z)"
assumes circ_def: "x⇧∘ = x ⋆ 1"
begin
text ‹Theorem 2.8›
subclass itering
apply unfold_locales
apply (simp add: circ_def while_associative while_sumstar)
apply (metis circ_def mult_1_right while_associative while_productstar while_slide)
apply (metis circ_def mult_1_right while_associative mult_1_left while_slide while_simulate_right_plus)
by (metis circ_def mult_1_right while_associative mult_1_left while_simulate_left_plus mult_right_dist_sup)
text ‹Theorem 8.5›
subclass extended_binary_itering
apply unfold_locales
by (simp add: while_associative while_increasing mult_assoc)
end
end
Theory Binary_Iterings_Nonstrict
section ‹Nonstrict Binary Iterings›
theory Binary_Iterings_Nonstrict
imports Omega_Algebras Binary_Iterings
begin
class nonstrict_itering = bounded_left_zero_omega_algebra + while +
assumes while_def: "x ⋆ y = x⇧ω ⊔ x⇧⋆ * y"
begin
text ‹Theorem 8.2›
subclass bounded_binary_itering
proof (unfold_locales)
fix x y z
show "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
by (metis sup_commute mult_assoc mult_left_dist_sup omega_loop_fixpoint omega_slide star.circ_slide while_def)
next
fix x y z
show "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
proof -
have 1: "(x ⊔ y) ⋆ z = (x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z)"
using mult_left_dist_sup omega_decompose star.circ_sup_9 sup_assoc while_def mult_assoc by auto
hence 2: "(x ⊔ y) ⋆ z ≤ (x ⋆ y) ⋆ (x ⋆ z)"
by (smt sup_mono sup_ge2 le_iff_sup mult_left_isotone omega_sub_dist star.circ_sub_dist while_def)
let ?rhs = "x⇧⋆ * y * ((x⇧ω ⊔ x⇧⋆ * y)⇧ω ⊔ (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z)) ⊔ (x⇧ω ⊔ x⇧⋆ * z)"
have "x⇧ω * (x⇧ω ⊔ x⇧⋆ * y)⇧ω ≤ x⇧ω"
by (simp add: omega_sub_vector)
hence "x⇧ω * (x⇧ω ⊔ x⇧⋆ * y)⇧ω ⊔ x⇧⋆ * y * (x⇧ω ⊔ x⇧⋆ * y)⇧ω ≤ ?rhs"
by (smt sup_commute sup_mono sup_ge1 mult_left_dist_sup order_trans)
hence 3: "(x⇧ω ⊔ x⇧⋆ * y)⇧ω ≤ ?rhs"
by (metis mult_right_dist_sup omega_unfold)
have "x⇧ω * (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ≤ x⇧ω"
by (simp add: omega_mult_star_2 omega_sub_vector)
hence "x⇧ω * (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ⊔ x⇧⋆ * y * (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ≤ ?rhs"
by (smt sup_commute sup_mono sup_ge2 mult_assoc mult_left_dist_sup order_trans)
hence "(x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ≤ ?rhs"
by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_loop_fixpoint)
hence "(x⇧ω ⊔ x⇧⋆ * y)⇧ω ⊔ (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ≤ ?rhs"
using 3 by simp
hence "(x⇧ω ⊔ x⇧⋆ * y)⇧ω ⊔ (x⇧ω ⊔ x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z) ≤ (x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * z)"
by (metis sup_commute omega_induct)
thus ?thesis
using 1 2 order.antisym while_def by force
qed
next
fix x y z
show "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
using mult_left_dist_sup sup_assoc sup_commute while_def by auto
next
fix x y z
show "(x ⋆ y) * z ≤ x ⋆ (y * z)"
using mult_semi_associative omega_sub_vector semiring.add_mono semiring.distrib_right while_def by fastforce
next
fix v w x y z
show "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
proof
assume "x * z ≤ z * (y ⋆ 1) ⊔ w"
hence 1: "x * z ≤ z * y⇧ω ⊔ z * y⇧⋆ ⊔ w"
by (metis mult_left_dist_sup mult_1_right while_def)
let ?rhs = "z * (y⇧ω ⊔ y⇧⋆ * v) ⊔ x⇧ω ⊔ x⇧⋆ * w * (y⇧ω ⊔ y⇧⋆ * v)"
have 2: "z * v ≤ ?rhs"
by (metis le_supI1 mult_left_sub_dist_sup_right omega_loop_fixpoint)
have "x * z * (y⇧ω ⊔ y⇧⋆ * v) ≤ ?rhs"
proof -
have "x * z * (y⇧ω ⊔ y⇧⋆ * v) ≤ (z * y⇧ω ⊔ z * y⇧⋆ ⊔ w) * (y⇧ω ⊔ y⇧⋆ * v)"
using 1 mult_left_isotone by auto
also have "... = z * (y⇧ω * (y⇧ω ⊔ y⇧⋆ * v) ⊔ y⇧⋆ * (y⇧ω ⊔ y⇧⋆ * v)) ⊔ w * (y⇧ω ⊔ y⇧⋆ * v)"
by (smt mult_assoc mult_left_dist_sup mult_right_dist_sup)
also have "... = z * (y⇧ω * (y⇧ω ⊔ y⇧⋆ * v) ⊔ y⇧ω ⊔ y⇧⋆ * v) ⊔ w * (y⇧ω ⊔ y⇧⋆ * v)"
by (smt sup_assoc mult_assoc mult_left_dist_sup star.circ_transitive_equal star_mult_omega)
also have "... ≤ z * (y⇧ω ⊔ y⇧⋆ * v) ⊔ x⇧⋆ * w * (y⇧ω ⊔ y⇧⋆ * v)"
by (smt sup_commute sup_mono sup_left_top mult_left_dist_sup mult_left_one mult_right_dist_sup mult_right_sub_dist_sup_left omega_vector order_refl star.circ_plus_one)
finally show ?thesis
by (smt sup_assoc sup_commute le_iff_sup)
qed
hence "x * ?rhs ≤ ?rhs"
by (smt sup_assoc sup_commute sup_ge1 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup omega_unfold star.circ_increasing star.circ_transitive_equal)
hence "z * v ⊔ x * ?rhs ≤ ?rhs"
using 2 le_supI by blast
hence "x⇧⋆ * z * v ≤ ?rhs"
by (simp add: star_left_induct mult_assoc)
hence "x⇧ω ⊔ x⇧⋆ * z * v ≤ ?rhs"
by (meson order_trans sup_ge1 sup_ge2 sup_least)
thus "x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
by (simp add: sup_assoc while_def mult_assoc)
qed
next
fix v w x y z
show "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
proof
assume "z * x ≤ y * (y ⋆ z) ⊔ w"
hence "z * x ≤ y * (y⇧ω ⊔ y⇧⋆ * z) ⊔ w"
by (simp add: while_def)
hence 1: "z * x ≤ y⇧ω ⊔ y * y⇧⋆ * z ⊔ w"
using mult_left_dist_sup omega_unfold mult_assoc by auto
let ?rhs = "y⇧ω ⊔ y⇧⋆ * z * v ⊔ y⇧⋆ * w * (x⇧ω ⊔ x⇧⋆ * v)"
have 2: "z * x⇧ω ≤ ?rhs"
proof -
have "z * x⇧ω ≤ y * y⇧⋆ * z * x⇧ω ⊔ y⇧ω * x⇧ω ⊔ w * x⇧ω"
using 1 by (smt sup_commute le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
also have "... ≤ y * y⇧⋆ * z * x⇧ω ⊔ y⇧ω ⊔ w * x⇧ω"
using omega_sub_vector semiring.add_mono by blast
also have "... = y * y⇧⋆ * (z * x⇧ω) ⊔ (y⇧ω ⊔ w * x⇧ω)"
by (simp add: sup_assoc mult_assoc)
finally have "z * x⇧ω ≤ (y * y⇧⋆)⇧ω ⊔ (y * y⇧⋆)⇧⋆ * (y⇧ω ⊔ w * x⇧ω)"
by (simp add: omega_induct sup_commute)
also have "... = y⇧ω ⊔ y⇧⋆ * w * x⇧ω"
by (simp add: left_plus_omega semiring.distrib_left star.left_plus_circ star_mult_omega mult_assoc)
also have "... ≤ ?rhs"
using mult_left_sub_dist_sup_left sup.mono sup_ge1 by blast
finally show ?thesis
.
qed
let ?rhs2 = "y⇧ω ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * (x⇧ω ⊔ x⇧⋆)"
have "?rhs2 * x ≤ ?rhs2"
proof -
have 3: "y⇧ω * x ≤ ?rhs2"
by (simp add: le_supI1 omega_sub_vector)
have "y⇧⋆ * z * x ≤ y⇧⋆ * (y⇧ω ⊔ y * y⇧⋆ * z ⊔ w)"
using 1 mult_right_isotone mult_assoc by auto
also have "... = y⇧ω ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w"
by (simp add: semiring.distrib_left star_mult_omega mult_assoc)
also have "... = y⇧ω ⊔ y * y⇧⋆ * z ⊔ y⇧⋆ * w"
by (simp add: star.circ_plus_same star.circ_transitive_equal mult_assoc)
also have "... ≤ y⇧ω ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w"
by (metis sup_left_isotone sup_right_isotone mult_left_isotone star.left_plus_below_circ)
also have "... ≤ y⇧ω ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧⋆"
using semiring.add_left_mono star.circ_back_loop_prefixpoint by auto
finally have 4: "y⇧⋆ * z * x ≤ ?rhs2"
using mult_left_sub_dist_sup_right order_lesseq_imp semiring.add_left_mono by blast
have "(x⇧ω ⊔ x⇧⋆) * x ≤ x⇧ω ⊔ x⇧⋆"
using omega_sub_vector semiring.distrib_right star.left_plus_below_circ star_plus sup_mono by fastforce
hence "y⇧⋆ * w * (x⇧ω ⊔ x⇧⋆) * x ≤ ?rhs2"
by (simp add: le_supI2 mult_right_isotone mult_assoc)
thus ?thesis
using 3 4 mult_right_dist_sup by force
qed
hence "z ⊔ ?rhs2 * x ≤ ?rhs2"
by (metis omega_loop_fixpoint sup.boundedE sup_ge1 sup_least)
hence 5: "z * x⇧⋆ ≤ ?rhs2"
using star_right_induct by blast
have "z * x⇧⋆ * v ≤ ?rhs"
proof -
have "z * x⇧⋆ * v ≤ ?rhs2 * v"
using 5 mult_left_isotone by auto
also have "... = y⇧ω * v ⊔ y⇧⋆ * z * v ⊔ y⇧⋆ * w * (x⇧ω * v ⊔ x⇧⋆ * v)"
using mult_right_dist_sup mult_assoc by auto
also have "... ≤ y⇧ω ⊔ y⇧⋆ * z * v ⊔ y⇧⋆ * w * (x⇧ω * v ⊔ x⇧⋆ * v)"
using omega_sub_vector semiring.add_right_mono by blast
also have "... ≤ ?rhs"
using mult_right_isotone omega_sub_vector semiring.add_left_mono semiring.add_right_mono by auto
finally show ?thesis
.
qed
hence "z * (x⇧ω ⊔ x⇧⋆ * v) ≤ ?rhs"
using 2 semiring.distrib_left mult_assoc by force
thus "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
by (simp add: semiring.distrib_left sup_assoc while_def mult_assoc)
qed
qed
text ‹Theorem 13.8›
lemma while_top:
"top ⋆ x = top"
by (metis sup_left_top star.circ_top star_omega_top while_def)
text ‹Theorem 13.7›
lemma while_one_top:
"1 ⋆ x = top"
by (simp add: omega_one while_def)
lemma while_finite_associative:
"x⇧ω = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
by (simp add: while_def mult_assoc)
lemma star_below_while:
"x⇧⋆ * y ≤ x ⋆ y"
by (simp add: while_def)
text ‹Theorem 13.9›
lemma while_sub_mult_one:
"x * (1 ⋆ y) ≤ 1 ⋆ x"
by (simp add: omega_one while_def)
lemma while_while_one:
"y ⋆ (x ⋆ 1) = y⇧ω ⊔ y⇧⋆ * x⇧ω ⊔ y⇧⋆ * x⇧⋆"
using mult_left_dist_sup sup_assoc while_def by auto
lemma while_simulate_4_plus:
assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
shows "y * x * x⇧⋆ ≤ x * (x ⋆ (1 ⊔ y))"
proof -
have 1: "x * (x ⋆ (1 ⊔ y)) = x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
using mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by force
hence "y * x * x⇧⋆ ≤ (x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y) * x⇧⋆"
using assms mult_left_isotone by auto
also have "... = x⇧ω * x⇧⋆ ⊔ x * x⇧⋆ * x⇧⋆ ⊔ x * x⇧⋆ * y * x⇧⋆"
using mult_right_dist_sup by force
also have "... = x * x⇧⋆ * (y * x * x⇧⋆) ⊔ x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
by (smt sup_assoc sup_commute mult_assoc omega_mult_star_2 star.circ_back_loop_fixpoint star.circ_plus_same star.circ_transitive_equal)
finally have "y * x * x⇧⋆ ≤ x * x⇧⋆ * (y * x * x⇧⋆) ⊔ (x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y)"
using sup_assoc by force
hence "y * x * x⇧⋆ ≤ (x * x⇧⋆)⇧ω ⊔ (x * x⇧⋆)⇧⋆ * (x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y)"
by (simp add: omega_induct sup_monoid.add_commute)
also have "... = x⇧ω ⊔ x⇧⋆ * (x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y)"
by (simp add: left_plus_omega star.left_plus_circ)
finally show ?thesis
using 1 by (metis while_def while_mult_star_exchange while_transitive)
qed
lemma while_simulate_4_omega:
assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
shows "y * x⇧ω ≤ x⇧ω"
proof -
have "x * (x ⋆ (1 ⊔ y)) = x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
using mult_1_right mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by auto
hence "y * x⇧ω ≤ (x⇧ω ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y) * x⇧ω"
by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
also have "... = x⇧ω * x⇧ω ⊔ x * x⇧⋆ * x⇧ω ⊔ x * x⇧⋆ * y * x⇧ω"
using semiring.distrib_right by auto
also have "... = x * x⇧⋆ * (y * x⇧ω) ⊔ x⇧ω"
by (metis sup_commute le_iff_sup mult_assoc omega_sub_vector omega_unfold star_mult_omega)
finally have "y * x⇧ω ≤ x * x⇧⋆ * (y * x⇧ω) ⊔ x⇧ω"
.
hence "y * x⇧ω ≤ (x * x⇧⋆)⇧ω ⊔ (x * x⇧⋆)⇧⋆ * x⇧ω"
by (simp add: omega_induct sup_commute)
thus ?thesis
by (metis sup_idem left_plus_omega star_mult_omega)
qed
text ‹Theorem 13.11›
lemma while_unfold_below:
"x = z ⊔ y * x ⟹ x ≤ y ⋆ z"
by (simp add: omega_induct while_def)
text ‹Theorem 13.12›
lemma while_unfold_below_sub:
"x ≤ z ⊔ y * x ⟹ x ≤ y ⋆ z"
by (simp add: omega_induct while_def)
text ‹Theorem 13.10›
lemma while_unfold_below_1:
"x = y * x ⟹ x ≤ y ⋆ 1"
by (simp add: while_unfold_below_sub)
lemma while_square_1:
"x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)"
by (metis mult_1_right omega_square star_square_2 while_def)
lemma while_absorb_below_one:
"y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x"
by (simp add: while_unfold_below_sub)
lemma while_loop_is_greatest_postfixpoint:
"is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)"
proof -
have "(y ⋆ z) ≤ (λx . y * x ⊔ z) (y ⋆ z)"
using sup_commute while_left_unfold by force
thus ?thesis
by (simp add: is_greatest_postfixpoint_def sup_commute while_unfold_below_sub)
qed
lemma while_loop_is_greatest_fixpoint:
"is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)"
by (simp add: omega_loop_is_greatest_fixpoint while_def)
end
class nonstrict_itering_zero = nonstrict_itering +
assumes mult_right_zero: "x * bot = bot"
begin
lemma while_finite_associative_2:
"x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
by (metis sup_bot_left sup_bot_right mult_assoc mult_right_zero while_def)
text ‹Theorem 13 counterexamples›
end
class nonstrict_itering_tarski = nonstrict_itering +
assumes tarski: "x ≤ x * top * x * top"
begin
text ‹Theorem 13.14›
lemma tarski_mult_top_idempotent:
"x * top = x * top * x * top"
by (metis sup_commute le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_left_top tarski top_mult_top)
lemma tarski_top_omega_below:
"x * top ≤ (x * top)⇧ω"
using omega_induct_mult order.refl mult_assoc tarski_mult_top_idempotent by auto
lemma tarski_top_omega:
"x * top = (x * top)⇧ω"
by (simp add: order.eq_iff mult_top_omega tarski_top_omega_below)
lemma tarski_below_top_omega:
"x ≤ (x * top)⇧ω"
using top_right_mult_increasing tarski_top_omega by auto
lemma tarski_mult_omega_omega:
"(x * y⇧ω)⇧ω = x * y⇧ω"
by (metis mult_assoc omega_vector tarski_top_omega)
lemma tarski_omega_idempotent:
"x⇧ω⇧ω = x⇧ω"
by (metis omega_vector tarski_top_omega)
lemma while_denest_2a:
"w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)"
proof -
have "(x⇧ω ⊔ x⇧⋆ * y * w)⇧ω = (x⇧⋆ * y * w)⇧⋆ * x⇧ω * (((x⇧⋆ * y * w)⇧⋆ * x⇧ω)⇧ω ⊔ ((x⇧⋆ * y * w)⇧⋆ * x⇧ω)⇧⋆ * (x⇧⋆ * y * w)⇧ω) ⊔ (x⇧⋆ * y * w)⇧ω"
by (metis sup_commute omega_decompose omega_loop_fixpoint)
also have "... ≤ (x⇧⋆ * y * w)⇧⋆ * x⇧ω ⊔ (x⇧⋆ * y * w)⇧ω"
by (metis sup_left_isotone mult_assoc mult_right_isotone omega_sub_vector)
finally have 1: "w * (x⇧ω ⊔ x⇧⋆ * y * w)⇧ω ≤ (w * x⇧⋆ * y)⇧⋆ * w * x⇧ω ⊔ (w * x⇧⋆ * y)⇧ω"
by (smt sup_commute le_iff_sup mult_assoc mult_left_dist_sup while_def while_slide)
have "(x⇧ω ⊔ x⇧⋆ * y * w)⇧⋆ * z = (x⇧⋆ * y * w)⇧⋆ * x⇧ω * ((x⇧⋆ * y * w)⇧⋆ * x⇧ω)⇧⋆ * (x⇧⋆ * y * w)⇧⋆ * z ⊔ (x⇧⋆ * y * w)⇧⋆ * z"
by (smt sup_commute mult_assoc star.circ_sup star.circ_loop_fixpoint)
also have "... ≤ (x⇧⋆ * y * w)⇧⋆ * x⇧ω ⊔ (x⇧⋆ * y * w)⇧⋆ * z"
by (smt sup_commute sup_right_isotone mult_assoc mult_right_isotone omega_sub_vector)
finally have "w * (x⇧ω ⊔ x⇧⋆ * y * w)⇧⋆ * z ≤ (w * x⇧⋆ * y)⇧⋆ * w * x⇧ω ⊔ (w * x⇧⋆ * y)⇧⋆ * w * z"
by (metis mult_assoc mult_left_dist_sup mult_right_isotone star.circ_slide)
hence "w * (x⇧ω ⊔ x⇧⋆ * y * w)⇧ω ⊔ w * (x⇧ω ⊔ x⇧⋆ * y * w)⇧⋆ * z ≤ (w * x⇧⋆ * y)⇧⋆ * (w * x⇧ω)⇧ω ⊔ (w * x⇧⋆ * y)⇧ω ⊔ (w * x⇧⋆ * y)⇧⋆ * w * z"
using 1 by (smt sup_assoc sup_commute le_iff_sup mult_assoc tarski_mult_omega_omega)
also have "... ≤ (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧⋆ * (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧ω ⊔ (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧ω ⊔ (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧⋆ * w * z"
by (metis sup_mono sup_ge1 sup_ge2 mult_isotone mult_left_isotone omega_isotone star.circ_isotone)
also have "... = (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧ω ⊔ (w * x⇧ω ⊔ w * x⇧⋆ * y)⇧⋆ * w * z"
by (simp add: star_mult_omega)
finally have "w * ((x⇧ω ⊔ x⇧⋆ * y * w)⇧ω ⊔ (x⇧ω ⊔ x⇧⋆ * y * w)⇧⋆ * z) ≤ w * ((x⇧ω ⊔ x⇧⋆ * y) * w)⇧ω ⊔ w * ((x⇧ω ⊔ x⇧⋆ * y) * w)⇧⋆ * z"
by (smt mult_assoc mult_left_dist_sup omega_slide star.circ_slide)
hence 2: "w * ((x ⋆ (y * w)) ⋆ z) ≤ w * (((x ⋆ y) * w) ⋆ z)"
by (simp add: mult_left_dist_sup while_def mult_assoc)
have "w * (((x ⋆ y) * w) ⋆ z) ≤ w * ((x ⋆ (y * w)) ⋆ z)"
by (simp add: mult_right_isotone while_left_isotone while_sub_associative)
thus ?thesis
using 2 order.antisym by auto
qed
lemma while_denest_3:
"(x ⋆ w) ⋆ x⇧ω = (x ⋆ w)⇧ω"
proof -
have 1: "(x ⋆ w) ⋆ x⇧ω = (x ⋆ w)⇧ω ⊔ (x ⋆ w)⇧⋆ * x⇧ω⇧ω"
by (simp add: while_def tarski_omega_idempotent)
also have "... ≤ (x ⋆ w)⇧ω ⊔ (x ⋆ w)⇧⋆ * (x⇧ω ⊔ x⇧⋆ * w)⇧ω"
using mult_right_isotone omega_sub_dist semiring.add_left_mono by blast
also have "... = (x ⋆ w)⇧ω"
by (simp add: star_mult_omega while_def)
finally show ?thesis
using 1 by (simp add: sup.order_iff)
qed
lemma while_denest_4a:
"(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
have "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w)⇧ω ⊔ ((x ⋆ w) ⋆ (x⇧⋆ * y * z))"
using while_def while_denest_3 while_left_dist_sup mult_assoc by auto
also have "... ≤ (x ⋆ w)⇧ω ⊔ ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
using mult_right_sub_dist_sup_right order.refl semiring.add_mono while_def while_right_isotone by auto
finally have 1: "(x ⋆ w) ⋆ (x ⋆ (y * z)) ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
by (simp add: while_def)
have "(x ⋆ w) ⋆ ((x ⋆ y) * z) ≤ (x ⋆ w) ⋆ (x ⋆ (y * z))"
by (simp add: while_right_isotone while_sub_associative)
thus ?thesis
using 1 order.antisym by auto
qed
text ‹Theorem 8.3›
subclass bounded_extended_binary_itering
apply unfold_locales
by (smt mult_assoc while_denest_2a while_denest_4a while_increasing while_slide)
text ‹Theorem 13.13›
lemma while_mult_top:
"(x * top) ⋆ z = z ⊔ x * top"
proof -
have 1: "z ⊔ x * top ≤ (x * top) ⋆ z"
by (metis le_supI sup_ge1 while_def while_increasing tarski_top_omega)
have "(x * top) ⋆ z = z ⊔ x * top * ((x * top) ⋆ z)"
using while_left_unfold by auto
also have "... ≤ z ⊔ x * top"
using mult_right_isotone sup_right_isotone top_greatest mult_assoc by auto
finally show ?thesis
using 1 order.antisym by auto
qed
lemma tarski_top_omega_below_2:
"x * top ≤ (x * top) ⋆ bot"
by (simp add: while_mult_top)
lemma tarski_top_omega_2:
"x * top = (x * top) ⋆ bot"
by (simp add: while_mult_top)
lemma tarski_below_top_omega_2:
"x ≤ (x * top) ⋆ bot"
using top_right_mult_increasing tarski_top_omega_2 by auto
end
class nonstrict_itering_tarski_zero = nonstrict_itering_tarski + nonstrict_itering_zero
begin
lemma while_bot_1:
"1 = (x * bot) ⋆ 1"
by (simp add: mult_right_zero while_zero)
text ‹Theorem 13 counterexamples›
end
end
Theory Tests
section ‹Tests›
theory Tests
imports Subset_Boolean_Algebras.Subset_Boolean_Algebras Base
begin
context subset_boolean_algebra_extended
begin
sublocale sba_dual: subset_boolean_algebra_extended where uminus = uminus and sup = inf and minus = "λx y . -(-x ⊓ y)" and inf = sup and bot = top and less_eq = greater_eq and less = greater and top = bot
apply unfold_locales
apply (simp add: inf_associative)
apply (simp add: inf_commutative)
using inf_cases_2 apply simp
using inf_closed apply simp
apply simp
apply simp
using sub_sup_closed sub_sup_demorgan apply simp
apply simp
apply (simp add: inf_commutative less_eq_inf)
by (metis inf_commutative inf_idempotent inf_left_dist_sup sub_less_def sup_absorb sup_right_zero top_double_complement)
lemma strict_leq_def:
"-x < -y ⟷ -x ≤ -y ∧ ¬ (-y ≤ -x)"
by (simp add: sba_dual.sba_dual.sub_less_def sba_dual.sba_dual.sub_less_eq_def)
lemma one_def:
"top = -bot"
by simp
end
class tests = times + uminus + one + ord + sup + bot +
assumes sub_assoc: "-x * (-y * -z) = (-x * -y) * -z"
assumes sub_comm: "-x * -y = -y * -x"
assumes sub_compl: "-x = -(--x * -y) * -(--x * --y)"
assumes sub_mult_closed: "-x * -y = --(-x * -y)"
assumes the_bot_def: "bot = (THE x . (∀y . x = -y * --y))"
assumes one_def: "1 = - bot"
assumes sup_def: "-x ⊔ -y = -(--x * --y)"
assumes leq_def: "-x ≤ -y ⟷ -x * -y = -x"
assumes strict_leq_def: "-x < -y ⟷ -x ≤ -y ∧ ¬ (-y ≤ -x)"
begin
sublocale tests_dual: subset_boolean_algebra_extended where uminus = uminus and sup = times and minus = "λx y . -(-x * y)" and inf = sup and bot = 1 and less_eq = greater_eq and less = greater and top = bot
apply unfold_locales
apply (simp add: sub_assoc)
apply (simp add: sub_comm)
apply (simp add: sub_compl)
using sub_mult_closed apply simp
apply (simp add: the_bot_def)
apply (simp add: one_def the_bot_def)
apply (simp add: sup_def)
apply simp
apply (simp add: leq_def sub_comm)
by (simp add: leq_def strict_leq_def sub_comm)
sublocale sba: subset_boolean_algebra_extended where uminus = uminus and sup = sup and minus = "λx y . -(-x ⊔ y)" and inf = times and bot = bot and less_eq = less_eq and less = less and top = 1 ..
text ‹sets and sequences of tests›
definition test_set :: "'a set ⇒ bool"
where "test_set A ≡ ∀x∈A . x = --x"
lemma mult_left_dist_test_set:
"test_set A ⟹ test_set { -p * x | x . x ∈ A }"
by (smt mem_Collect_eq sub_mult_closed test_set_def)
lemma mult_right_dist_test_set:
"test_set A ⟹ test_set { x * -p | x . x ∈ A }"
by (smt mem_Collect_eq sub_mult_closed test_set_def)
lemma sup_left_dist_test_set:
"test_set A ⟹ test_set { -p ⊔ x | x . x ∈ A }"
by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)
lemma sup_right_dist_test_set:
"test_set A ⟹ test_set { x ⊔ -p | x . x ∈ A }"
by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)
lemma test_set_closed:
"A ⊆ B ⟹ test_set B ⟹ test_set A"
using test_set_def by auto
definition test_seq :: "(nat ⇒ 'a) ⇒ bool"
where "test_seq t ≡ ∀n . t n = --t n"
lemma test_seq_test_set:
"test_seq t ⟹ test_set { t n | n::nat . True }"
using test_seq_def test_set_def by auto
definition nat_test :: "(nat ⇒ 'a) ⇒ 'a ⇒ bool"
where "nat_test t s ≡ (∀n . t n = --t n) ∧ s = --s ∧ (∀n . t n ≤ s) ∧ (∀x y . (∀n . t n * -x ≤ -y) ⟶ s * -x ≤ -y)"
lemma nat_test_seq:
"nat_test t s ⟹ test_seq t"
by (simp add: nat_test_def test_seq_def)
primrec pSum :: "(nat ⇒ 'a) ⇒ nat ⇒ 'a"
where "pSum f 0 = bot"
| "pSum f (Suc m) = pSum f m ⊔ f m"
lemma pSum_test:
"test_seq t ⟹ pSum t m = --(pSum t m)"
apply (induct m)
apply simp
by (smt pSum.simps(2) tests_dual.sba_dual.sub_sup_closed test_seq_def)
lemma pSum_test_nat:
"nat_test t s ⟹ pSum t m = --(pSum t m)"
by (metis nat_test_seq pSum_test)
lemma pSum_upper:
"test_seq t ⟹ i<m ⟹ t i ≤ pSum t m"
proof (induct m)
show "test_seq t ⟹ i<0 ⟹ t i ≤ pSum t 0"
by (smt less_zeroE)
next
fix n
assume "test_seq t ⟹ i<n ⟹ t i ≤ pSum t n"
hence "test_seq t ⟹ i<n ⟹ t i ≤ pSum t (Suc n)"
by (smt (z3) pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_left tests_dual.transitive test_seq_def)
thus "test_seq t ⟹ i<Suc n ⟹ t i ≤ pSum t (Suc n)"
by (metis less_Suc_eq pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_right test_seq_def)
qed
lemma pSum_below:
"test_seq t ⟹ (∀m<k . t m * -p ≤ -q) ⟹ pSum t k * -p ≤ -q"
apply (induct k)
apply (simp add: tests_dual.top_greatest)
by (smt (verit, ccfv_threshold) tests_dual.sup_right_dist_inf pSum.simps(2) pSum_test test_seq_def sub_mult_closed less_Suc_eq tests_dual.sba_dual.sub_associative tests_dual.sba_dual.sub_less_eq_def)
lemma pSum_below_nat:
"nat_test t s ⟹ (∀m<k . t m * -p ≤ -q) ⟹ pSum t k * -p ≤ -q"
by (simp add: nat_test_seq pSum_below)
lemma pSum_below_sum:
"nat_test t s ⟹ pSum t x ≤ s"
by (smt (verit, ccfv_threshold) tests_dual.sup_right_unit nat_test_def one_def pSum_below_nat pSum_test_nat)
lemma ascending_chain_sup_left:
"ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . -p ⊔ t n) ∧ test_seq (λn . -p ⊔ t n)"
by (smt (z3) ord.ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)
lemma ascending_chain_sup_right:
"ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . t n ⊔ -p) ∧ test_seq (λn . t n ⊔ -p)"
by (smt ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)
lemma ascending_chain_mult_left:
"ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . -p * t n) ∧ test_seq (λn . -p * t n)"
by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)
lemma ascending_chain_mult_right:
"ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . t n * -p) ∧ test_seq (λn . t n * -p)"
by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)
lemma descending_chain_sup_left:
"descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . -p ⊔ t n) ∧ test_seq (λn . -p ⊔ t n)"
by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)
lemma descending_chain_sup_right:
"descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . t n ⊔ -p) ∧ test_seq (λn . t n ⊔ -p)"
by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)
lemma descending_chain_mult_left:
"descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . -p * t n) ∧ test_seq (λn . -p * t n)"
by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)
lemma descending_chain_mult_right:
"descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . t n * -p) ∧ test_seq (λn . t n * -p)"
by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)
end
end
Theory Test_Iterings
section ‹Test Iterings›
theory Test_Iterings
imports Stone_Kleene_Relation_Algebras.Iterings Tests
begin
class test_itering = itering + tests + while +
assumes while_def: "p ⋆ y = (p * y)⇧∘ * -p"
begin
lemma wnf_lemma_5:
"(-p ⊔ -q) * (-q * x ⊔ --q * y) = -q * x ⊔ --q * -p * y"
by (smt (z3) mult_left_dist_sup sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_idempotent tests_dual.sup_idempotent mult_assoc tests_dual.wnf_lemma_3)
lemma test_case_split_left_equal:
"-z * x = -z * y ⟹ --z * x = --z * y ⟹ x = y"
by (metis case_split_left_equal tests_dual.inf_complement)
lemma preserves_equation:
"-y * x ≤ x * -y ⟷ -y * x = -y * x * -y"
apply (rule iffI)
apply (simp add: test_preserves_equation tests_dual.sub_bot_least)
by (simp add: test_preserves_equation tests_dual.sub_bot_least)
text ‹Theorem 5›
lemma preserve_test:
"-y * x ≤ x * -y ⟹ -y * x⇧∘ = -y * x⇧∘ * -y"
using circ_simulate preserves_equation by blast
text ‹Theorem 5›
lemma import_test:
"-y * x ≤ x * -y ⟹ -y * x⇧∘ = -y * (-y * x)⇧∘"
by (simp add: circ_import tests_dual.sub_bot_least)
definition ite :: "'a ⇒ 'a ⇒ 'a ⇒ 'a" ("_ ⊲ _ ⊳ _" [58,58,58] 57)
where "x ⊲ p ⊳ y ≡ p * x ⊔ -p * y"
definition it :: "'a ⇒ 'a ⇒ 'a" ("_ ⊳ _" [58,58] 57)
where "p ⊳ x ≡ p * x ⊔ -p"
definition assigns :: "'a ⇒ 'a ⇒ 'a ⇒ bool"
where "assigns x p q ≡ x = x * (p * q ⊔ -p * -q)"
definition preserves :: "'a ⇒ 'a ⇒ bool"
where "preserves x p ≡ p * x ≤ x * p ∧ -p * x ≤ x * -p"
lemma ite_neg:
"x ⊲ -p ⊳ y = y ⊲ --p ⊳ x"
by (simp add: ite_def sup_commute)
lemma ite_import_true:
"x ⊲ -p ⊳ y = -p * x ⊲ -p ⊳ y"
by (metis ite_def tests_dual.sup_idempotent mult_assoc)
lemma ite_import_false:
"x ⊲ -p ⊳ y = x ⊲ -p ⊳ --p * y"
by (metis ite_import_true ite_neg)
lemma ite_import_true_false:
"x ⊲ -p ⊳ y = -p * x ⊲ -p ⊳ --p * y"
using ite_import_false ite_import_true by auto
lemma ite_context_true:
"-p * (x ⊲ -p ⊳ y) = -p * x"
by (metis sup_monoid.add_0_left tests_dual.sup_right_zero tests_dual.top_double_complement wnf_lemma_5 sup_bot_right ite_def mult_assoc mult_left_zero)
lemma ite_context_false:
"--p * (x ⊲ -p ⊳ y) = --p * y"
by (metis ite_neg ite_context_true)
lemma ite_context_import:
"-p * (x ⊲ -q ⊳ y) = -p * (x ⊲ -p * -q ⊳ y)"
by (smt ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup)
lemma ite_conjunction:
"(x ⊲ -q ⊳ y) ⊲ -p ⊳ y = x ⊲ -p * -q ⊳ y"
by (smt sup_assoc sup_commute ite_def mult_assoc tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_complement_intro)
lemma ite_disjunction:
"x ⊲ -p ⊳ (x ⊲ -q ⊳ y) = x ⊲ -p ⊔ -q ⊳ y"
by (smt (z3) tests_dual.sba_dual.sub_sup_closed sup_assoc ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_demorgan)
lemma wnf_lemma_6:
"(-p ⊔ -q) * (x ⊲ --p * -q ⊳ y) = (-p ⊔ -q) * (y ⊲ -p ⊳ x)"
by (smt (z3) ite_conjunction ite_context_false ite_context_true semiring.distrib_right tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.sub_inf_def tests_dual.sba_dual.sup_complement_intro tests_dual.sub_complement)
lemma it_ite:
"-p ⊳ x = x ⊲ -p ⊳ 1"
by (simp add: it_def ite_def)
lemma it_neg:
"--p ⊳ x = 1 ⊲ -p ⊳ x"
using it_ite ite_neg by auto
lemma it_import_true:
"-p ⊳ x = -p ⊳ -p * x"
using it_ite ite_import_true by auto
lemma it_context_true:
"-p * (-p ⊳ x) = -p * x"
by (simp add: it_ite ite_context_true)
lemma it_context_false:
"--p * (-p ⊳ x) = --p"
using it_ite ite_context_false by force
lemma while_unfold_it:
"-p ⋆ x = -p ⊳ x * (-p ⋆ x)"
by (metis circ_loop_fixpoint it_def mult_assoc while_def)
lemma while_context_false:
"--p * (-p ⋆ x) = --p"
by (metis it_context_false while_unfold_it)
lemma while_context_true:
"-p * (-p ⋆ x) = -p * x * (-p ⋆ x)"
by (metis it_context_true mult_assoc while_unfold_it)
lemma while_zero:
"bot ⋆ x = 1"
by (metis circ_zero mult_left_one mult_left_zero one_def while_def)
lemma wnf_lemma_7:
"1 * (bot ⋆ 1) = 1"
by (simp add: while_zero)
lemma while_import_condition:
"-p ⋆ x = -p ⋆ -p * x"
by (metis mult_assoc tests_dual.sup_idempotent while_def)
lemma while_import_condition_2:
"-p * -q ⋆ x = -p * -q ⋆ -p * x"
by (metis mult_assoc tests_dual.sup_idempotent sub_comm while_def)
lemma wnf_lemma_8:
"-r * (-p ⊔ --p * -q) ⋆ (x ⊲ --p * -q ⊳ y) = -r * (-p ⊔ -q) ⋆ (y ⊲ -p ⊳ x)"
by (metis mult_assoc while_def wnf_lemma_6 tests_dual.sba_dual.sup_complement_intro)
text ‹Theorem 6 - see Theorem 31 on page 329 of Back and von Wright, Acta Informatica 36:295-334, 1999›
lemma split_merge_loops:
assumes "--p * y ≤ y * --p"
shows "(-p ⊔ -q) ⋆ (x ⊲ -p ⊳ y) = (-p ⋆ x) * (-q ⋆ y)"
proof -
have "-p ⊔ -q ⋆ (x ⊲ -p ⊳ y) = (-p * x ⊔ --p * -q * y)⇧∘ * --p * --q"
by (smt ite_def mult_assoc sup_commute tests_dual.inf_demorgan while_def wnf_lemma_5)
thus ?thesis
by (smt assms circ_sup_1 circ_slide import_test mult_assoc preserves_equation sub_comm while_context_false while_def)
qed
lemma assigns_same:
"assigns x (-p) (-p)"
by (simp add: assigns_def)
lemma preserves_equation_test:
"preserves x (-p) ⟷ -p * x = -p * x * -p ∧ --p * x = --p * x * --p"
using preserves_def preserves_equation by auto
lemma preserves_test:
"preserves (-q) (-p)"
using tests_dual.sub_commutative preserves_def by auto
lemma preserves_zero:
"preserves bot (-p)"
using tests_dual.sba_dual.sub_bot_def preserves_test by blast
lemma preserves_one:
"preserves 1 (-p)"
using preserves_def by force
lemma preserves_sup:
"preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x ⊔ y) (-p)"
by (simp add: mult_left_dist_sup mult_right_dist_sup preserves_equation_test)
lemma preserves_mult:
"preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x * y) (-p)"
by (smt (verit, best) mult_assoc preserves_equation_test)
lemma preserves_ite:
"preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x ⊲ -q ⊳ y) (-p)"
by (simp add: ite_def preserves_mult preserves_sup preserves_test)
lemma preserves_it:
"preserves x (-p) ⟹ preserves (-q ⊳ x) (-p)"
by (simp add: it_ite preserves_ite preserves_one)
lemma preserves_circ:
"preserves x (-p) ⟹ preserves (x⇧∘) (-p)"
by (meson circ_simulate preserves_def)
lemma preserves_while:
"preserves x (-p) ⟹ preserves (-q ⋆ x) (-p)"
using while_def preserves_circ preserves_mult preserves_test by auto
lemma preserves_test_neg:
"preserves x (-p) ⟹ preserves x (--p)"
using preserves_def by auto
lemma preserves_import_circ:
"preserves x (-p) ⟹ -p * x⇧∘ = -p * (-p * x)⇧∘"
using import_test preserves_def by blast
lemma preserves_simulate:
"preserves x (-p) ⟹ -p * x⇧∘ = -p * x⇧∘ * -p"
using preserve_test preserves_def by auto
lemma preserves_import_ite:
assumes "preserves z (-p)"
shows "z * (x ⊲ -p ⊳ y) = z * x ⊲ -p ⊳ z * y"
proof -
have 1: "-p * z * (x ⊲ -p ⊳ y) = -p * (z * x ⊲ -p ⊳ z * y)"
by (smt assms ite_context_true mult_assoc preserves_equation_test)
have "--p * z * (x ⊲ -p ⊳ y) = --p * (z * x ⊲ -p ⊳ z * y)"
by (smt (z3) assms ite_context_false mult_assoc preserves_equation_test)
thus ?thesis
using 1 by (metis mult_assoc test_case_split_left_equal)
qed
lemma preserves_while_context:
"preserves x (-p) ⟹ -p * (-q ⋆ x) = -p * (-p * -q ⋆ x)"
by (smt (verit, del_insts) mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan preserves_import_circ preserves_mult preserves_simulate preserves_test while_def)
lemma while_ite_context_false:
assumes "preserves y (-p)"
shows "--p * (-p ⊔ -q ⋆ (x ⊲ -p ⊳ y)) = --p * (-q ⋆ y)"
proof -
have "--p * (-p ⊔ -q ⋆ (x ⊲ -p ⊳ y)) = --p * (--p * -q * y)⇧∘ * -(-p ⊔ -q)"
by (smt (z3) assms import_test mult_assoc preserves_equation preserves_equation_test sub_comm while_def tests_dual.sba_dual.sub_sup_demorgan preserves_test split_merge_loops while_context_false)
thus ?thesis
by (metis (no_types, lifting) assms preserves_def mult.assoc split_merge_loops while_context_false)
qed
text ‹Theorem 7.1›
lemma while_ite_norm:
assumes "assigns z (-p) (-q)"
and "preserves x1 (-q)"
and "preserves x2 (-q)"
and "preserves y1 (-q)"
and "preserves y2 (-q)"
shows "z * (x1 * (-r1 ⋆ y1) ⊲ -p ⊳ x2 * (-r2 ⋆ y2)) = z * (x1 ⊲ -q ⊳ x2) * ((-q * -r1 ⊔ --q * -r2) ⋆ (y1 ⊲ -q ⊳ y2))"
proof -
have 1: "-(-q * -r1 ⊔ --q * -r2) = -q * --r1 ⊔ --q * --r2"
by (smt (z3) tests_dual.complement_2 tests_dual.sub_sup_closed tests_dual.case_duality tests_dual.sub_sup_demorgan)
have "-p * -q * x1 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧∘ * (-q * --r1 ⊔ --q * --r2) = -p * -q * x1 * -q * (-q * (-q * -r1 * y1 ⊔ --q * -r2 * y2))⇧∘ * (-q * --r1 ⊔ --q * --r2)"
by (smt (verit, del_insts) assms(2,4,5) mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test)
also have "... = -p * -q * x1 * -q * (-q * -r1 * y1)⇧∘ * (-q * --r1 ⊔ --q * --r2)"
using ite_context_true ite_def mult_assoc by auto
finally have 2: "-p * -q * x1 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧∘ * (-q * --r1 ⊔ --q * --r2) = -p * -q * x1 * (-r1 * y1)⇧∘ * --r1"
by (smt (verit, del_insts) assms ite_context_true ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test)
have "--p * --q * x2 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧∘ * (-q * --r1 ⊔ --q * --r2) = --p * --q * x2 * --q * (--q * (-q * -r1 * y1 ⊔ --q * -r2 * y2))⇧∘ * (-q * --r1 ⊔ --q * --r2)"
by (smt (verit, del_insts) assms mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test preserves_test_neg)
also have "... = --p * --q * x2 * --q * (--q * -r2 * y2)⇧∘ * (-q * --r1 ⊔ --q * --r2)"
using ite_context_false ite_def mult_assoc by auto
finally have "--p * --q * x2 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧∘ * (-q * --r1 ⊔ --q * --r2) = --p * --q * x2 * (-r2 * y2)⇧∘ * --r2"
by (smt (verit, del_insts) assms(3,5) ite_context_false ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test preserves_test_neg)
thus ?thesis
using 1 2 by (smt (z3) assms(1) assigns_def mult_assoc mult_right_dist_sup while_def ite_context_false ite_context_true tests_dual.sub_commutative)
qed
lemma while_it_norm:
"assigns z (-p) (-q) ⟹ preserves x (-q) ⟹ preserves y (-q) ⟹ z * (-p ⊳ x * (-r ⋆ y)) = z * (-q ⊳ x) * (-q * -r ⋆ y)"
by (metis sup_bot_right tests_dual.sup_right_zero it_context_true it_ite tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)
lemma while_else_norm:
"assigns z (-p) (-q) ⟹ preserves x (-q) ⟹ preserves y (-q) ⟹ z * (1 ⊲ -p ⊳ x * (-r ⋆ y)) = z * (1 ⊲ -q ⊳ x) * (--q * -r ⋆ y)"
by (metis sup_bot_left tests_dual.sup_right_zero ite_context_false tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)
lemma while_while_pre_norm:
"-p ⋆ x * (-q ⋆ y) = -p ⊳ x * (-p ⊔ -q ⋆ (y ⊲ -q ⊳ x))"
by (smt sup_commute circ_sup_1 circ_left_unfold circ_slide it_def ite_def mult_assoc mult_left_one mult_right_dist_sup tests_dual.inf_demorgan while_def wnf_lemma_5)
text ‹Theorem 7.2›
lemma while_while_norm:
"assigns z (-p) (-r) ⟹ preserves x (-r) ⟹ preserves y (-r) ⟹ z * (-p ⋆ x * (-q ⋆ y)) = z * (-r ⊳ x) * (-r * (-p ⊔ -q) ⋆ (y ⊲ -q ⊳ x))"
by (smt tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite while_it_norm while_while_pre_norm)
lemma while_seq_replace:
"assigns z (-p) (-q) ⟹ z * (-p ⋆ x * z) * y = z * (-q ⋆ x * z) * y"
by (smt assigns_def circ_slide mult_assoc tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_2 tests_dual.wnf_lemma_3 tests_dual.wnf_lemma_4 while_def)
lemma while_ite_replace:
"assigns z (-p) (-q) ⟹ z * (x ⊲ -p ⊳ y) = z * (x ⊲ -q ⊳ y)"
by (smt assigns_def ite_def mult_assoc mult_left_dist_sup sub_comm tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_3)
lemma while_post_norm_an:
assumes "preserves y (-p)"
shows "(-p ⋆ x) * y = y ⊲ --p ⊳ (-p ⋆ x * (--p ⊳ y))"
proof -
have "-p * (-p * x * (--p * y ⊔ -p))⇧∘ * --p = -p * x * ((--p * y ⊔ -p) * -p * x)⇧∘ * (--p * y ⊔ -p) * --p"
by (metis circ_slide_1 while_def mult_assoc while_context_true)
also have "... = -p * x * (--p * y * bot ⊔ -p * x)⇧∘ * --p * y"
by (smt assms sup_bot_right mult_assoc tests_dual.sup_complement tests_dual.sup_idempotent mult_left_zero mult_right_dist_sup preserves_equation_test sub_comm)
finally have "-p * (-p * x * (--p * y ⊔ -p))⇧∘ * --p = -p * x * (-p * x)⇧∘ * --p * y"
by (metis circ_sup_mult_zero sup_commute mult_assoc)
thus ?thesis
by (smt circ_left_unfold tests_dual.double_negation it_def ite_def mult_assoc mult_left_one mult_right_dist_sup while_def)
qed
lemma while_post_norm:
"preserves y (-p) ⟹ (-p ⋆ x) * y = -p ⋆ x * (1 ⊲ -p ⊳ y) ⊲ -p ⊳ y"
using it_neg ite_neg while_post_norm_an by force
lemma wnf_lemma_9:
assumes "assigns z (-p) (-q)"
and "preserves x1 (-q)"
and "preserves y1 (-q)"
and "preserves x2 (-q)"
and "preserves y2 (-q)"
and "preserves x2 (-p)"
and "preserves y2 (-p)"
shows "z * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * (x1 ⊲ -p ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
proof -
have "z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * --p * --q * x2 * --q * (--q * (-q * -p ⊔ -r) ⋆ (y1 ⊲ -q * -p ⊳ y2))"
by (smt (verit, del_insts) assms(3-5) tests_dual.double_negation ite_context_false mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context)
also have "... = z * --p * --q * x2 * --q * (--q * -r ⋆ --q * y2)"
by (smt sup_bot_left tests_dual.double_negation ite_conjunction ite_context_false mult_assoc tests_dual.sup_complement mult_left_dist_sup mult_left_zero while_import_condition_2)
also have "... = z * --p * --q * x2 * (-r ⋆ y2)"
by (metis assms(4,5) mult_assoc preserves_equation_test preserves_test_neg preserves_while_context while_import_condition_2)
finally have 1: "z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
by (smt assms(6,7) ite_context_false mult_assoc preserves_equation_test sub_comm while_ite_context_false)
have "z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * -p * -q * (x1 ⊲ -q ⊳ x2) * -q * (-q * (-p ⊔ -r) ⋆ -q * (y1 ⊲ -p ⊳ y2))"
by (smt (verit, del_insts) assms(2-5) tests_dual.double_negation ite_context_import mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
hence "z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
by (smt assms(2-5) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
thus ?thesis
using 1 by (smt assms(1) assigns_def mult_assoc mult_left_dist_sup mult_right_dist_sup while_ite_replace)
qed
text ‹Theorem 7.3›
lemma while_seq_norm:
assumes "assigns z1 (-r1) (-q)"
and "preserves x2 (-q)"
and "preserves y2 (-q)"
and "preserves z2 (-q)"
and "z1 * z2 = z2 * z1"
and "assigns z2 (-q) (-r)"
and "preserves y1 (-r)"
and "preserves z1 (-r)"
and "preserves x2 (-r)"
and "preserves y2 (-r)"
shows "x1 * z1 * z2 * (-r1 ⋆ y1 * z1) * x2 * (-r2 ⋆ y2) = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2))"
proof -
have 1: "preserves (y1 * z1 * (1 ⊲ -q ⊳ x2)) (-r)"
by (simp add: assms(7-9) ite_def preserves_mult preserves_sup preserves_test)
hence 2: "preserves (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2) (-r)"
by (simp add: assms(10) preserves_ite)
have "x1 * z1 * z2 * (-r1 ⋆ y1 * z1) * x2 * (-r2 ⋆ y2) = x1 * z1 * z2 * (-q ⋆ y1 * z1) * x2 * (-r2 ⋆ y2)"
using assms(1,5) mult_assoc while_seq_replace by auto
also have "... = x1 * z1 * z2 * (-q ⋆ y1 * z1 * (1 ⊲ -q ⊳ x2 * (-r2 ⋆ y2)) ⊲ -q ⊳ x2 * (-r2 ⋆ y2))"
by (smt assms(2,3) mult_assoc preserves_mult preserves_while while_post_norm)
also have "... = x1 * z1 * (z2 * (-q ⋆ y1 * z1 * (1 ⊲ -q ⊳ x2) * (--q * -r2 ⋆ y2)) ⊲ -q ⊳ z2 * x2 * (-r2 ⋆ y2))"
by (smt assms(2-4) assigns_same mult_assoc preserves_import_ite while_else_norm)
also have "... = x1 * z1 * (z2 * (-r ⊳ y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -q ⊳ z2 * x2 * (-r2 ⋆ y2))"
by (smt assms(6-10) tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_while_norm wnf_lemma_8)
also have "... = x1 * z1 * z2 * ((-r ⊳ y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
by (smt assms(4,6) mult_assoc preserves_import_ite while_ite_replace)
also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
by (smt mult_assoc it_context_true ite_import_true)
also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * -r * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
using 1 by (simp add: preserves_equation_test)
also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * -r * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
using 2 by (smt (z3) tests_dual.sba_dual.sub_sup_closed mult_assoc preserves_while_context)
also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -q ⊳ x2 * (-r2 ⋆ y2))"
by (smt assms(6-9) tests_dual.double_negation ite_import_true mult_assoc tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_one while_ite_replace)
also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * (-q ⊔ -r2) ⊔ --r * -r2) ⋆ ((y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2) ⊲ -r ⊳ y2))"
by (smt assms(6-10) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_ite_norm)
also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * (-q ⊔ -r2) ⊔ --r * -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r * -q ⊳ y2))"
using ite_conjunction by simp
also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * -q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r * -q ⊳ y2))"
by (smt (z3) mult_left_dist_sup sup_assoc tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)
also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2))"
using 1 by (metis assms(2,3,6,9,10) mult_assoc wnf_lemma_9)
finally show ?thesis
.
qed
end
end
Theory N_Semirings
section ‹N-Semirings›
theory N_Semirings
imports Test_Iterings Omega_Algebras
begin
class n_semiring = bounded_idempotent_left_zero_semiring + n + L +
assumes n_bot : "n(bot) = bot"
assumes n_top : "n(top) = 1"
assumes n_dist_sup : "n(x ⊔ y) = n(x) ⊔ n(y)"
assumes n_export : "n(n(x) * y) = n(x) * n(y)"
assumes n_sub_mult_bot: "n(x) = n(x * bot) * n(x)"
assumes n_L_split : "x * n(y) * L = x * bot ⊔ n(x * y) * L"
assumes n_split : "x ≤ x * bot ⊔ n(x * L) * top"
begin
lemma n_sub_one:
"n(x) ≤ 1"
by (metis sup_left_top sup_ge2 n_dist_sup n_top)
text ‹Theorem 15›
lemma n_isotone:
"x ≤ y ⟹ n(x) ≤ n(y)"
by (metis le_iff_sup n_dist_sup)
lemma n_mult_idempotent:
"n(x) * n(x) = n(x)"
by (metis mult_assoc mult_1_right n_export n_sub_mult_bot n_top)
text ‹Theorem 15.3›
lemma n_mult_bot:
"n(x) = n(x * bot)"
by (metis sup_commute sup_left_top sup_bot_right mult_left_dist_sup mult_1_right n_dist_sup n_sub_mult_bot n_top)
lemma n_mult_left_upper_bound:
"n(x) ≤ n(x * y)"
by (metis mult_right_isotone n_isotone n_mult_bot bot_least)
lemma n_mult_right_bot:
"n(x) * bot = bot"
by (metis sup_left_top sup_bot_left mult_left_one mult_1_right n_export n_dist_sup n_sub_mult_bot n_top n_bot)
text ‹Theorem 15.9›
lemma n_mult_n:
"n(x * n(y)) = n(x)"
by (metis mult_assoc n_mult_right_bot n_mult_bot)
lemma n_mult_left_absorb_sup:
"n(x) * (n(x) ⊔ n(y)) = n(x)"
by (metis sup_left_top mult_left_dist_sup mult_1_right n_dist_sup n_mult_idempotent n_top)
lemma n_mult_right_absorb_sup:
"(n(x) ⊔ n(y)) * n(y) = n(y)"
by (metis sup_commute sup_left_top mult_left_one mult_right_dist_sup n_dist_sup n_mult_idempotent n_top)
lemma n_sup_left_absorb_mult:
"n(x) ⊔ n(x) * n(y) = n(x)"
using mult_left_dist_sup n_mult_idempotent n_mult_left_absorb_sup by auto
lemma n_sup_right_absorb_mult:
"n(x) * n(y) ⊔ n(y) = n(y)"
using mult_right_dist_sup n_mult_idempotent n_mult_right_absorb_sup by auto
lemma n_mult_commutative:
"n(x) * n(y) = n(y) * n(x)"
by (smt sup_commute mult_left_dist_sup mult_right_dist_sup n_sup_left_absorb_mult n_sup_right_absorb_mult n_export n_mult_idempotent)
lemma n_sup_left_dist_mult:
"n(x) ⊔ n(y) * n(z) = (n(x) ⊔ n(y)) * (n(x) ⊔ n(z))"
by (metis sup_assoc mult_left_dist_sup mult_right_dist_sup n_sup_right_absorb_mult n_mult_commutative n_mult_left_absorb_sup)
lemma n_sup_right_dist_mult:
"n(x) * n(y) ⊔ n(z) = (n(x) ⊔ n(z)) * (n(y) ⊔ n(z))"
by (simp add: sup_commute n_sup_left_dist_mult)
lemma n_order:
"n(x) ≤ n(y) ⟷ n(x) * n(y) = n(x)"
by (metis le_iff_sup n_sup_right_absorb_mult n_mult_left_absorb_sup)
lemma n_mult_left_lower_bound:
"n(x) * n(y) ≤ n(x)"
by (simp add: sup.orderI n_sup_left_absorb_mult)
lemma n_mult_right_lower_bound:
"n(x) * n(y) ≤ n(y)"
by (simp add: le_iff_sup n_sup_right_absorb_mult)
lemma n_mult_least_upper_bound:
"n(x) ≤ n(y) ∧ n(x) ≤ n(z) ⟷ n(x) ≤ n(y) * n(z)"
by (metis order.trans mult_left_isotone n_mult_commutative n_mult_right_lower_bound n_order)
lemma n_mult_left_divisibility:
"n(x) ≤ n(y) ⟷ (∃z . n(x) = n(y) * n(z))"
by (metis n_mult_commutative n_mult_left_lower_bound n_order)
lemma n_mult_right_divisibility:
"n(x) ≤ n(y) ⟷ (∃z . n(x) = n(z) * n(y))"
by (simp add: n_mult_commutative n_mult_left_divisibility)
text ‹Theorem 15.1›
lemma n_one:
"n(1) = bot"
by (metis mult_left_one n_mult_bot n_bot)
lemma n_split_equal:
"x ⊔ n(x * L) * top = x * bot ⊔ n(x * L) * top"
using n_split order_trans sup.cobounded1 sup_same_context zero_right_mult_decreasing by blast
lemma n_split_top:
"x * top ≤ x * bot ⊔ n(x * L) * top"
by (metis mult_left_isotone n_split vector_bot_closed vector_mult_closed vector_sup_closed vector_top_closed)
text ‹Theorem 15.2›
lemma n_L:
"n(L) = 1"
by (metis sup_bot_left order.antisym mult_left_one n_export n_isotone n_mult_commutative n_split_top n_sub_one n_top)
text ‹Theorem 15.5›
lemma n_split_L:
"x * L = x * bot ⊔ n(x * L) * L"
by (metis mult_1_right n_L n_L_split)
lemma n_n_L:
"n(n(x) * L) = n(x)"
by (simp add: n_export n_L)
lemma n_L_decreasing:
"n(x) * L ≤ x"
by (metis mult_left_zero n_L_split order_trans sup.orderI zero_right_mult_decreasing mult_assoc n_mult_bot)
text ‹Theorem 15.10›
lemma n_galois:
"n(x) ≤ n(y) ⟷ n(x) * L ≤ y"
by (metis order.trans mult_left_isotone n_L_decreasing n_isotone n_n_L)
text ‹Theorem 15.6›
lemma split_L:
"x * L ≤ x * bot ⊔ L"
by (metis sup_commute sup_left_isotone n_galois n_L n_split_L n_sub_one)
text ‹Theorem 15.7›
lemma L_left_zero:
"L * x = L"
by (metis order.antisym mult.left_neutral mult_left_zero zero_right_mult_decreasing n_L n_L_decreasing n_mult_bot mult.assoc)
text ‹Theorem 15.8›
lemma n_mult:
"n(x * n(y) * L) = n(x * y)"
using n_L_split n_dist_sup sup.absorb2 n_mult_left_upper_bound n_mult_bot n_n_L by auto
lemma n_mult_top:
"n(x * n(y) * top) = n(x * y)"
by (metis mult_1_right n_mult n_top)
text ‹Theorem 15.4›
lemma n_top_L:
"n(x * top) = n(x * L)"
by (metis mult_1_right n_L n_mult_top)
lemma n_top_split:
"x * n(y) * top ≤ x * bot ⊔ n(x * y) * top"
by (metis mult_assoc n_mult n_mult_right_bot n_split_top)
lemma n_mult_right_upper_bound:
"n(x * y) ≤ n(z) ⟷ n(x) ≤ n(z) ∧ x * n(y) * L ≤ x * bot ⊔ n(z) * L"
apply (rule iffI)
apply (metis sup_right_isotone order.eq_iff mult_isotone n_L_split n_mult_left_upper_bound order_trans)
by (smt (verit, ccfv_threshold) n_dist_sup n_export sup.absorb_iff2 n_mult n_mult_commutative n_mult_bot n_n_L)
lemma n_preserves_equation:
"n(y) * x ≤ x * n(y) ⟷ n(y) * x = n(y) * x * n(y)"
using eq_refl test_preserves_equation n_mult_idempotent n_sub_one by auto
definition ni :: "'a ⇒ 'a"
where "ni x = n(x) * L"
lemma ni_bot:
"ni(bot) = bot"
by (simp add: n_bot ni_def)
lemma ni_one:
"ni(1) = bot"
by (simp add: n_one ni_def)
lemma ni_L:
"ni(L) = L"
by (simp add: n_L ni_def)
lemma ni_top:
"ni(top) = L"
by (simp add: n_top ni_def)
lemma ni_dist_sup:
"ni(x ⊔ y) = ni(x) ⊔ ni(y)"
by (simp add: mult_right_dist_sup n_dist_sup ni_def)
lemma ni_mult_bot:
"ni(x) = ni(x * bot)"
using n_mult_bot ni_def by auto
lemma ni_split:
"x * ni(y) = x * bot ⊔ ni(x * y)"
using n_L_split mult_assoc ni_def by auto
lemma ni_decreasing:
"ni(x) ≤ x"
by (simp add: n_L_decreasing ni_def)
lemma ni_isotone:
"x ≤ y ⟹ ni(x) ≤ ni(y)"
using mult_left_isotone n_isotone ni_def by auto
lemma ni_mult_left_upper_bound:
"ni(x) ≤ ni(x * y)"
using mult_left_isotone n_mult_left_upper_bound ni_def by force
lemma ni_idempotent:
"ni(ni(x)) = ni(x)"
by (simp add: n_n_L ni_def)
lemma ni_below_L:
"ni(x) ≤ L"
using n_L n_galois n_sub_one ni_def by auto
lemma ni_left_zero:
"ni(x) * y = ni(x)"
by (simp add: L_left_zero mult_assoc ni_def)
lemma ni_split_L:
"x * L = x * bot ⊔ ni(x * L)"
using n_split_L ni_def by auto
lemma ni_top_L:
"ni(x * top) = ni(x * L)"
by (simp add: n_top_L ni_def)
lemma ni_galois:
"ni(x) ≤ ni(y) ⟷ ni(x) ≤ y"
by (metis n_galois n_n_L ni_def)
lemma ni_mult:
"ni(x * ni(y)) = ni(x * y)"
using mult_assoc n_mult ni_def by auto
lemma ni_n_order:
"ni(x) ≤ ni(y) ⟷ n(x) ≤ n(y)"
using n_galois ni_def ni_galois by auto
lemma ni_n_equal:
"ni(x) = ni(y) ⟷ n(x) = n(y)"
by (metis n_n_L ni_def)
lemma ni_mult_right_upper_bound:
"ni(x * y) ≤ ni(z) ⟷ ni(x) ≤ ni(z) ∧ x * ni(y) ≤ x * bot ⊔ ni(z)"
using mult_assoc n_mult_right_upper_bound ni_def ni_n_order by auto
lemma n_ni:
"n(ni(x)) = n(x)"
by (simp add: n_n_L ni_def)
lemma ni_n:
"ni(n(x)) = bot"
by (metis n_mult_right_bot ni_mult_bot ni_bot)
lemma ni_n_galois:
"n(x) ≤ n(y) ⟷ ni(x) ≤ y"
by (simp add: n_galois ni_def)
lemma n_mult_ni:
"n(x * ni(y)) = n(x * y)"
using ni_mult ni_n_equal by auto
lemma ni_mult_n:
"ni(x * n(y)) = ni(x)"
by (simp add: n_mult_n ni_def)
lemma ni_export:
"ni(n(x) * y) = n(x) * ni(y)"
by (simp add: n_mult_right_bot ni_split)
lemma ni_mult_top:
"ni(x * n(y) * top) = ni(x * y)"
by (simp add: n_mult_top ni_def)
lemma ni_n_bot:
"ni(x) = bot ⟷ n(x) = bot"
using n_bot ni_n_equal ni_bot by force
lemma ni_n_L:
"ni(x) = L ⟷ n(x) = 1"
using n_L ni_L ni_n_equal by force
end
typedef (overloaded) 'a nImage = "{ x::'a::n_semiring . (∃y::'a . x = n(y)) }"
by auto
lemma simp_nImage[simp]:
"∃y . Rep_nImage x = n(y)"
using Rep_nImage by simp
setup_lifting type_definition_nImage
text ‹Theorem 15›
instantiation nImage :: (n_semiring) bounded_idempotent_semiring
begin
lift_definition sup_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is sup
by (metis n_dist_sup)
lift_definition times_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is times
by (metis n_export)
lift_definition bot_nImage :: "'a nImage" is bot
by (metis n_bot)
lift_definition one_nImage :: "'a nImage" is 1
using n_L by auto
lift_definition top_nImage :: "'a nImage" is 1
using n_L by auto
lift_definition less_eq_nImage :: "'a nImage ⇒ 'a nImage ⇒ bool" is less_eq .
lift_definition less_nImage :: "'a nImage ⇒ 'a nImage ⇒ bool" is less .
instance
apply intro_classes
apply (simp add: less_eq_nImage.rep_eq less_le_not_le less_nImage.rep_eq)
apply (simp add: less_eq_nImage.rep_eq)
using less_eq_nImage.rep_eq apply force
apply (simp add: less_eq_nImage.rep_eq Rep_nImage_inject)
apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
apply (simp add: less_eq_nImage.rep_eq sup_nImage.rep_eq)
apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
apply (simp add: bot_nImage.rep_eq less_eq_nImage.rep_eq)
apply (simp add: sup_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq mult_left_dist_sup)
apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inverse mult_right_dist_sup)
apply (smt (z3) times_nImage.rep_eq Rep_nImage_inverse bot_nImage.rep_eq mult_left_zero)
using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
apply (simp add: one_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq)
apply (smt (verit, del_insts) sup_nImage.rep_eq Rep_nImage Rep_nImage_inject mem_Collect_eq n_sub_one sup.absorb2 top_nImage.rep_eq)
apply (simp add: less_eq_nImage.rep_eq mult.assoc times_nImage.rep_eq)
using Rep_nImage_inject mult.assoc times_nImage.rep_eq apply fastforce
using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inject mult_left_dist_sup)
by (smt (z3) Rep_nImage_inject bot_nImage.rep_eq n_mult_right_bot simp_nImage times_nImage.rep_eq)
end
text ‹Theorem 15›
instantiation nImage :: (n_semiring) bounded_distrib_lattice
begin
lift_definition inf_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is times
by (metis n_export)
instance
apply intro_classes
apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_left_lower_bound simp_nImage)
apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_right_lower_bound simp_nImage)
apply (smt (z3) inf_nImage_def le_iff_sup less_eq_nImage.rep_eq mult_right_dist_sup n_mult_left_absorb_sup simp_nImage times_nImage.rep_eq times_nImage_def)
apply simp
by (smt (z3) Rep_nImage_inject inf_nImage.rep_eq n_sup_right_dist_mult simp_nImage sup.commute sup_nImage.rep_eq)
end
class n_itering = bounded_itering + n_semiring
begin
lemma mult_L_circ:
"(x * L)⇧∘ = 1 ⊔ x * L"
by (metis L_left_zero circ_mult mult_assoc)
lemma mult_L_circ_mult:
"(x * L)⇧∘ * y = y ⊔ x * L"
by (metis L_left_zero mult_L_circ mult_assoc mult_left_one mult_right_dist_sup)
lemma circ_L:
"L⇧∘ = L ⊔ 1"
by (metis L_left_zero sup_commute circ_left_unfold)
lemma circ_n_L:
"x⇧∘ * n(x) * L = x⇧∘ * bot"
by (metis sup_bot_left circ_left_unfold circ_plus_same mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split)
lemma n_circ_left_unfold:
"n(x⇧∘) = n(x * x⇧∘)"
by (metis circ_n_L circ_plus_same n_mult n_mult_bot)
lemma ni_circ:
"ni(x)⇧∘ = 1 ⊔ ni(x)"
by (simp add: mult_L_circ ni_def)
lemma circ_ni:
"x⇧∘ * ni(x) = x⇧∘ * bot"
using circ_n_L ni_def mult_assoc by auto
lemma ni_circ_left_unfold:
"ni(x⇧∘) = ni(x * x⇧∘)"
by (simp add: ni_def n_circ_left_unfold)
lemma n_circ_import:
"n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧∘ = n(y) * (n(y) * x)⇧∘"
by (simp add: circ_import n_mult_idempotent n_sub_one)
end
class n_omega_itering = left_omega_conway_semiring + n_itering +
assumes circ_circ: "x⇧∘⇧∘ = L ⊔ x⇧⋆"
begin
lemma L_below_one_circ:
"L ≤ 1⇧∘"
by (metis sup_left_divisibility circ_circ circ_one)
lemma circ_below_L_sup_star:
"x⇧∘ ≤ L ⊔ x⇧⋆"
by (metis circ_circ circ_increasing)
lemma L_sup_circ_sup_star:
"L ⊔ x⇧∘ = L ⊔ x⇧⋆"
by (metis circ_circ circ_star star_circ)
lemma circ_one_L:
"1⇧∘ = L ⊔ 1"
using circ_circ circ_one star_one by auto
lemma one_circ_zero:
"L = 1⇧∘ * bot"
by (metis L_left_zero circ_L circ_ni circ_one_L circ_plus_same ni_L)
lemma circ_not_simulate:
"(∀x y z . x * z ≤ z * y ⟶ x⇧∘ * z ≤ z * y⇧∘) ⟶ 1 = bot"
by (metis L_left_zero circ_one_L order.eq_iff mult_left_one mult_left_zero mult_right_sub_dist_sup_left n_L n_bot bot_least)
lemma star_circ_L:
"x⇧⋆⇧∘ = L ⊔ x⇧⋆"
by (simp add: circ_circ star_circ)
lemma circ_circ_2:
"x⇧∘⇧∘ = L ⊔ x⇧∘"
by (simp add: L_sup_circ_sup_star circ_circ)
lemma circ_sup_6:
"L ⊔ (x ⊔ y)⇧∘ = (x⇧∘ * y⇧∘)⇧∘"
by (metis circ_circ_2 sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_decompose_4)
lemma circ_sup_7:
"(x⇧∘ * y⇧∘)⇧∘ = L ⊔ (x ⊔ y)⇧⋆"
using L_sup_circ_sup_star circ_sup_6 by auto
end
class n_omega_algebra_2 = bounded_left_zero_omega_algebra + n_semiring + Omega +
assumes Omega_def: "x⇧Ω = n(x⇧ω) * L ⊔ x⇧⋆"
begin
lemma mult_L_star:
"(x * L)⇧⋆ = 1 ⊔ x * L"
by (simp add: L_left_zero transitive_star mult_assoc)
lemma mult_L_omega:
"(x * L)⇧ω = x * L"
by (metis L_left_zero omega_slide)
lemma mult_L_sup_star:
"(x * L ⊔ y)⇧⋆ = y⇧⋆ ⊔ y⇧⋆ * x * L"
by (metis L_left_zero star.mult_zero_sup_circ_2 sup_commute mult_assoc)
lemma mult_L_sup_omega:
"(x * L ⊔ y)⇧ω = y⇧ω ⊔ y⇧⋆ * x * L"
by (metis L_left_zero mult_bot_add_omega sup_commute mult_assoc)
lemma mult_L_sup_circ:
"(x * L ⊔ y)⇧Ω = n(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
by (smt sup_assoc sup_commute Omega_def le_iff_sup mult_L_sup_omega mult_L_sup_star mult_right_dist_sup n_L_decreasing n_dist_sup)
lemma circ_sup_n:
"(x⇧Ω * y)⇧Ω * x⇧Ω = n((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L)"
by (smt L_left_zero sup_assoc sup_commute Omega_def mult_L_sup_circ mult_assoc mult_left_dist_sup mult_right_dist_sup)
text ‹Theorem 20.6›
lemma n_omega_induct:
"n(y) ≤ n(x * y ⊔ z) ⟹ n(y) ≤ n(x⇧ω ⊔ x⇧⋆ * z)"
by (smt sup_commute mult_assoc n_dist_sup n_galois n_mult omega_induct)
lemma n_Omega_left_unfold:
"1 ⊔ x * x⇧Ω = x⇧Ω"
proof -
have "1 ⊔ x * x⇧Ω = 1 ⊔ x * n(x⇧ω) * L ⊔ x * x⇧⋆"
by (simp add: Omega_def semiring.distrib_left sup_assoc mult_assoc)
also have "... = n(x * x⇧ω) * L ⊔ (1 ⊔ x * x⇧⋆)"
by (metis sup_assoc sup_commute sup_bot_left mult_left_dist_sup n_L_split)
also have "... = n(x⇧ω) * L ⊔ x⇧⋆"
using omega_unfold star_left_unfold_equal by auto
also have "... = x⇧Ω"
by (simp add: Omega_def)
finally show ?thesis
.
qed
lemma n_Omega_circ_sup:
"(x ⊔ y)⇧Ω = (x⇧Ω * y)⇧Ω * x⇧Ω"
proof -
have "(x⇧Ω * y)⇧Ω * x⇧Ω = n((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L)"
by (simp add: circ_sup_n)
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * bot ⊔ (x⇧⋆ * y)⇧⋆ * x⇧⋆"
using n_L_split sup.left_commute sup_commute by auto
also have "... = n((x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * x⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * x⇧⋆"
by (smt sup_assoc sup_bot_left mult_left_dist_sup mult_right_dist_sup n_dist_sup)
also have "... = (x ⊔ y)⇧Ω"
by (simp add: Omega_def omega_decompose star.circ_sup_9)
finally show ?thesis
..
qed
lemma n_Omega_circ_simulate_right_sup:
assumes "z * x ≤ y * y⇧Ω * z ⊔ w"
shows "z * x⇧Ω ≤ y⇧Ω * (z ⊔ w * x⇧Ω)"
proof -
have "z * x ≤ y * y⇧Ω * z ⊔ w"
by (simp add: assms)
also have "... = y * n(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
using L_left_zero Omega_def mult_right_dist_sup semiring.distrib_left mult_assoc by auto
finally have 1: "z * x ≤ n(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
by (metis sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_L_split omega_unfold)
hence "(n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆) * x ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (n(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w) ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt L_left_zero sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint)
also have "... = n(y⇧ω) * L ⊔ y⇧⋆ * n(y⇧ω) * L ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
using semiring.distrib_left sup_assoc mult_assoc by auto
also have "... = n(y⇧ω) * L ⊔ y⇧⋆ * n(y⇧ω) * L ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt (verit, ccfv_SIG) le_supI1 order.refl semiring.add_mono star.circ_back_loop_prefixpoint sup.bounded_iff sup.coboundedI1 sup.mono sup_left_divisibility sup_right_divisibility sup_same_context)
also have "... = n(y⇧ω) * L ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup n_L_split star_mult_omega)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (meson mult_left_isotone order_refl semiring.add_left_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_left_isotone)
finally have 2: "z * x⇧⋆ ≤ n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt le_supI1 le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
have "z * x * x⇧ω ≤ n(y⇧ω) * L ⊔ y * y⇧⋆ * z * x⇧ω ⊔ w * x⇧ω"
using 1 by (smt (verit, del_insts) L_left_zero mult_assoc mult_left_isotone mult_right_dist_sup)
hence "n(z * x * x⇧ω) ≤ n(y * y⇧⋆ * z * x⇧ω ⊔ n(y⇧ω) * L ⊔ w * x⇧ω)"
by (simp add: n_isotone sup_commute)
hence "n(z * x⇧ω) ≤ n(y⇧ω ⊔ y⇧⋆ * w * x⇧ω)"
by (smt (verit, del_insts) sup_assoc sup_commute left_plus_omega le_iff_sup mult_assoc mult_left_dist_sup n_L_decreasing n_omega_induct omega_unfold star.left_plus_circ star_mult_omega)
hence "n(z * x⇧ω) * L ≤ n(y⇧ω) * L ⊔ y⇧⋆ * w * n(x⇧ω) * L"
by (metis n_dist_sup n_galois n_mult n_n_L)
hence "z * n(x⇧ω) * L ≤ z * bot ⊔ n(y⇧ω) * L ⊔ y⇧⋆ * w * n(x⇧ω) * L"
using n_L_split semiring.add_left_mono sup_assoc by auto
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L"
by (smt (z3) order.trans mult_1_left mult_right_sub_dist_sup_left semiring.add_right_mono star_left_unfold_equal sup_commute zero_right_mult_decreasing)
finally have "z * n(x⇧ω) * L ≤ n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * n(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
using le_supI1 by blast
thus ?thesis
using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed
lemma n_Omega_circ_simulate_left_sup:
assumes "x * z ≤ z * y⇧Ω ⊔ w"
shows "x⇧Ω * z ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
proof -
have "x * (z * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆) = x * z * n(y⇧ω) * L ⊔ x * z * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x * x⇧⋆ * w * n(y⇧ω) * L ⊔ x * x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup n_L_split omega_unfold)
also have "... ≤ (z * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w) * n(y⇧ω) * L ⊔ (z * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w) * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
also have "... = z * n(y⇧ω) * L ⊔ z * y⇧⋆ * n(y⇧ω) * L ⊔ w * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
also have "... = z * n(y⇧ω) * L ⊔ w * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc n_L_split star_mult_omega zero_right_mult_decreasing)
finally have "x * (z * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆) ≤ z * n(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ n(x⇧ω) * L ⊔ x⇧⋆ * w * n(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
thus "x⇧Ω * z ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_supI1 le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed
end
text ‹Theorem 2.6 and Theorem 19›
sublocale n_omega_algebra_2 < nL_omega: itering where circ = Omega
apply unfold_locales
apply (simp add: n_Omega_circ_sup)
apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup n_L_split omega_slide star.circ_mult)
apply (simp add: n_Omega_circ_simulate_right_sup)
using n_Omega_circ_simulate_left_sup by auto
sublocale n_omega_algebra_2 < nL_omega: n_omega_itering where circ = Omega
apply unfold_locales
by (smt Omega_def sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_left_one n_L_split n_top ni_below_L ni_def star_involutive star_mult_omega star_omega_top zero_right_mult_decreasing)
sublocale n_omega_algebra_2 < nL_omega: left_zero_kleene_conway_semiring where circ = Omega ..
sublocale n_omega_algebra_2 < nL_star: left_omega_conway_semiring where circ = star ..
context n_omega_algebra_2
begin
lemma circ_sup_8:
"n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ≤ (x⇧⋆ * y)⇧Ω * x⇧Ω"
by (metis sup_ge1 nL_omega.circ_sup_4 Omega_def mult_left_isotone n_isotone omega_sum_unfold_3 order_trans)
lemma n_split_omega_omega:
"x⇧ω ≤ x⇧ω * bot ⊔ n(x⇧ω) * top"
by (metis n_split n_top_L omega_vector)
text ‹Theorem 20.1›
lemma n_below_n_star:
"n(x) ≤ n(x⇧⋆)"
by (simp add: n_isotone star.circ_increasing)
text ‹Theorem 20.2›
lemma n_star_below_n_omega:
"n(x⇧⋆) ≤ n(x⇧ω)"
by (metis n_mult_left_upper_bound star_mult_omega)
lemma n_below_n_omega:
"n(x) ≤ n(x⇧ω)"
using order.trans n_below_n_star n_star_below_n_omega by blast
text ‹Theorem 20.4›
lemma star_n_L:
"x⇧⋆ * n(x) * L = x⇧⋆ * bot"
by (metis sup_bot_left mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split star_left_unfold_equal star_plus)
lemma star_L_split:
assumes "y ≤ z"
and "x * z * L ≤ x * bot ⊔ z * L"
shows "x⇧⋆ * y * L ≤ x⇧⋆ * bot ⊔ z * L"
proof -
have "x * (x⇧⋆ * bot ⊔ z * L) ≤ x⇧⋆ * bot ⊔ x * z * L"
by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
also have "... ≤ x⇧⋆ * bot ⊔ x * bot ⊔ z * L"
using assms(2) semiring.add_left_mono sup_assoc by auto
also have "... = x⇧⋆ * bot ⊔ z * L"
using mult_left_isotone star.circ_increasing sup.absorb_iff2 sup_commute by auto
finally have "y * L ⊔ x * (x⇧⋆ * bot ⊔ z * L) ≤ x⇧⋆ * bot ⊔ z * L"
by (metis assms(1) le_sup_iff sup_ge2 mult_left_isotone order_trans)
thus ?thesis
by (simp add: star_left_induct mult_assoc)
qed
lemma star_L_split_same:
"x * y * L ≤ x * bot ⊔ y * L ⟹ x⇧⋆ * y * L = x⇧⋆ * bot ⊔ y * L"
apply (rule order.antisym)
apply (simp add: star_L_split)
by (metis bot_least le_supI mult_isotone nL_star.star_below_circ star.circ_loop_fixpoint sup.cobounded2 mult_assoc)
lemma star_n_L_split_equal:
"n(x * y) ≤ n(y) ⟹ x⇧⋆ * n(y) * L = x⇧⋆ * bot ⊔ n(y) * L"
by (simp add: n_mult_right_upper_bound star_L_split_same)
lemma n_star_mult:
"n(x * y) ≤ n(y) ⟹ n(x⇧⋆ * y) = n(x⇧⋆) ⊔ n(y)"
by (metis n_dist_sup n_mult n_mult_bot n_n_L star_n_L_split_equal)
text ‹Theorem 20.3›
lemma n_omega_mult:
"n(x⇧ω * y) = n(x⇧ω)"
by (simp add: n_isotone n_mult_left_upper_bound omega_sub_vector order.eq_iff)
lemma n_star_left_unfold:
"n(x⇧⋆) = n(x * x⇧⋆)"
by (metis n_mult n_mult_bot star.circ_plus_same star_n_L)
lemma ni_star_below_ni_omega:
"ni(x⇧⋆) ≤ ni(x⇧ω)"
by (simp add: ni_n_order n_star_below_n_omega)
lemma ni_below_ni_omega:
"ni(x) ≤ ni(x⇧ω)"
by (simp add: ni_n_order n_below_n_omega)
lemma ni_star:
"ni(x)⇧⋆ = 1 ⊔ ni(x)"
by (simp add: mult_L_star ni_def)
lemma ni_omega:
"ni(x)⇧ω = ni(x)"
using mult_L_omega ni_def by auto
lemma ni_omega_induct:
"ni(y) ≤ ni(x * y ⊔ z) ⟹ ni(y) ≤ ni(x⇧ω ⊔ x⇧⋆ * z)"
using n_omega_induct ni_n_order by blast
lemma star_ni:
"x⇧⋆ * ni(x) = x⇧⋆ * bot"
using ni_def mult_assoc star_n_L by auto
lemma star_ni_split_equal:
"ni(x * y) ≤ ni(y) ⟹ x⇧⋆ * ni(y) = x⇧⋆ * bot ⊔ ni(y)"
using ni_def ni_mult_right_upper_bound mult_assoc star_L_split_same by auto
lemma ni_star_mult:
"ni(x * y) ≤ ni(y) ⟹ ni(x⇧⋆ * y) = ni(x⇧⋆) ⊔ ni(y)"
using mult_right_dist_sup ni_def ni_n_order n_star_mult by auto
lemma ni_omega_mult:
"ni(x⇧ω * y) = ni(x⇧ω)"
by (simp add: ni_def n_omega_mult)
lemma ni_star_left_unfold:
"ni(x⇧⋆) = ni(x * x⇧⋆)"
by (simp add: ni_def n_star_left_unfold)
lemma n_star_import:
assumes "n(y) * x ≤ x * n(y)"
shows "n(y) * x⇧⋆ = n(y) * (n(y) * x)⇧⋆"
proof (rule order.antisym)
have "n(y) * (n(y) * x)⇧⋆ * x ≤ n(y) * (n(y) * x)⇧⋆"
by (smt assms mult_assoc mult_right_dist_sup mult_right_sub_dist_sup_left n_mult_idempotent n_preserves_equation star.circ_back_loop_fixpoint)
thus "n(y) * x⇧⋆ ≤ n(y) * (n(y) * x)⇧⋆"
using assms eq_refl n_mult_idempotent n_sub_one star.circ_import by auto
next
show "n(y) * (n(y) * x)⇧⋆ ≤ n(y) * x⇧⋆"
by (simp add: assms n_mult_idempotent n_sub_one star.circ_import)
qed
lemma n_omega_export:
"n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧ω = (n(y) * x)⇧ω"
apply (rule order.antisym)
apply (simp add: n_preserves_equation omega_simulation)
by (metis mult_right_isotone mult_1_right n_sub_one omega_isotone omega_slide)
lemma n_omega_import:
"n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧ω = n(y) * (n(y) * x)⇧ω"
by (simp add: n_mult_idempotent omega_import)
text ‹Theorem 20.5›
lemma star_n_omega_top:
"x⇧⋆ * n(x⇧ω) * top = x⇧⋆ * bot ⊔ n(x⇧ω) * top"
by (smt (verit, del_insts) le_supI le_sup_iff sup_right_divisibility order.antisym mult_assoc nL_star.circ_mult_omega nL_star.star_zero_below_circ_mult n_top_split star.circ_loop_fixpoint)
end
end
Theory N_Semirings_Boolean
section ‹Boolean N-Semirings›
theory N_Semirings_Boolean
imports N_Semirings
begin
class an =
fixes an :: "'a ⇒ 'a"
class an_semiring = bounded_idempotent_left_zero_semiring + L + n + an + uminus +
assumes an_complement: "an(x) ⊔ n(x) = 1"
assumes an_dist_sup : "an(x ⊔ y) = an(x) * an(y)"
assumes an_export : "an(an(x) * y) = n(x) ⊔ an(y)"
assumes an_mult_zero : "an(x) = an(x * bot)"
assumes an_L_split : "x * n(y) * L = x * bot ⊔ n(x * y) * L"
assumes an_split : "an(x * L) * x ≤ x * bot"
assumes an_uminus : "-x = an(x * L)"
begin
text ‹Theorem 21›
lemma n_an_def:
"n(x) = an(an(x) * L)"
by (metis an_dist_sup an_export an_split bot_least mult_right_isotone semiring.add_nonneg_eq_0_iff sup.orderE top_greatest vector_bot_closed)
text ‹Theorem 21›
lemma an_complement_bot:
"an(x) * n(x) = bot"
by (metis an_dist_sup an_split bot_least le_iff_sup mult_left_zero sup_commute n_an_def)
text ‹Theorem 21›
lemma an_n_def:
"an(x) = n(an(x) * L)"
by (smt (verit, ccfv_threshold) an_complement_bot an_complement mult.right_neutral mult_left_dist_sup mult_right_dist_sup sup_commute n_an_def)
lemma an_case_split_left:
"an(z) * x ≤ y ∧ n(z) * x ≤ y ⟷ x ≤ y"
by (metis le_sup_iff an_complement mult_left_one mult_right_dist_sup)
lemma an_case_split_right:
"x * an(z) ≤ y ∧ x * n(z) ≤ y ⟷ x ≤ y"
by (metis le_sup_iff an_complement mult_1_right mult_left_dist_sup)
lemma split_sub:
"x * y ≤ z ⊔ x * top"
by (simp add: le_supI2 mult_right_isotone)
text ‹Theorem 21›
subclass n_semiring
apply unfold_locales
apply (metis an_dist_sup an_split mult_left_zero sup.absorb2 sup_bot_left sup_commute n_an_def)
apply (metis sup_left_top an_complement an_dist_sup an_export mult_assoc n_an_def)
apply (metis an_dist_sup an_export mult_assoc n_an_def)
apply (metis an_dist_sup an_export an_n_def mult_right_dist_sup n_an_def)
apply (metis sup_idem an_dist_sup an_mult_zero n_an_def)
apply (simp add: an_L_split)
by (meson an_case_split_left an_split le_supI1 split_sub)
lemma n_complement_bot:
"n(x) * an(x) = bot"
by (metis an_complement_bot an_n_def n_an_def)
lemma an_bot:
"an(bot) = 1"
by (metis sup_bot_right an_complement n_bot)
lemma an_one:
"an(1) = 1"
by (metis sup_bot_right an_complement n_one)
lemma an_L:
"an(L) = bot"
using an_one n_one n_an_def by auto
lemma an_top:
"an(top) = bot"
by (metis mult_left_one n_complement_bot n_top)
lemma an_export_n:
"an(n(x) * y) = an(x) ⊔ an(y)"
by (metis an_export an_n_def n_an_def)
lemma n_export_an:
"n(an(x) * y) = an(x) * n(y)"
by (metis an_n_def n_export)
lemma n_an_mult_commutative:
"n(x) * an(y) = an(y) * n(x)"
by (metis sup_commute an_dist_sup n_an_def)
lemma an_mult_commutative:
"an(x) * an(y) = an(y) * an(x)"
by (metis sup_commute an_dist_sup)
lemma an_mult_idempotent:
"an(x) * an(x) = an(x)"
by (metis sup_idem an_dist_sup)
lemma an_sub_one:
"an(x) ≤ 1"
using an_complement sup.cobounded1 by fastforce
text ‹Theorem 21›
lemma an_antitone:
"x ≤ y ⟹ an(y) ≤ an(x)"
by (metis an_n_def an_dist_sup n_order sup.absorb1)
lemma an_mult_left_upper_bound:
"an(x * y) ≤ an(x)"
by (metis an_antitone an_mult_zero mult_right_isotone bot_least)
lemma an_mult_right_zero:
"an(x) * bot = bot"
by (metis an_n_def n_mult_right_bot)
lemma n_mult_an:
"n(x * an(y)) = n(x)"
by (metis an_n_def n_mult_n)
lemma an_mult_n:
"an(x * n(y)) = an(x)"
by (metis an_n_def n_an_def n_mult_n)
lemma an_mult_an:
"an(x * an(y)) = an(x)"
by (metis an_mult_n an_n_def)
lemma an_mult_left_absorb_sup:
"an(x) * (an(x) ⊔ an(y)) = an(x)"
by (metis an_n_def n_mult_left_absorb_sup)
lemma an_mult_right_absorb_sup:
"(an(x) ⊔ an(y)) * an(y) = an(y)"
by (metis an_n_def n_mult_right_absorb_sup)
lemma an_sup_left_absorb_mult:
"an(x) ⊔ an(x) * an(y) = an(x)"
using an_case_split_right sup_absorb1 by blast
lemma an_sup_right_absorb_mult:
"an(x) * an(y) ⊔ an(y) = an(y)"
using an_case_split_left sup_absorb2 by blast
lemma an_sup_left_dist_mult:
"an(x) ⊔ an(y) * an(z) = (an(x) ⊔ an(y)) * (an(x) ⊔ an(z))"
by (metis an_n_def n_sup_left_dist_mult)
lemma an_sup_right_dist_mult:
"an(x) * an(y) ⊔ an(z) = (an(x) ⊔ an(z)) * (an(y) ⊔ an(z))"
by (simp add: an_sup_left_dist_mult sup_commute)
lemma an_n_order:
"an(x) ≤ an(y) ⟷ n(y) ≤ n(x)"
by (smt (verit) an_n_def an_dist_sup le_iff_sup n_dist_sup n_mult_right_absorb_sup sup.orderE n_an_def)
lemma an_order:
"an(x) ≤ an(y) ⟷ an(x) * an(y) = an(x)"
by (metis an_n_def n_order)
lemma an_mult_left_lower_bound:
"an(x) * an(y) ≤ an(x)"
using an_case_split_right by blast
lemma an_mult_right_lower_bound:
"an(x) * an(y) ≤ an(y)"
by (simp add: an_sup_right_absorb_mult le_iff_sup)
lemma an_n_mult_left_lower_bound:
"an(x) * n(y) ≤ an(x)"
using an_case_split_right by blast
lemma an_n_mult_right_lower_bound:
"an(x) * n(y) ≤ n(y)"
using an_case_split_left by auto
lemma n_an_mult_left_lower_bound:
"n(x) * an(y) ≤ n(x)"
using an_case_split_right by auto
lemma n_an_mult_right_lower_bound:
"n(x) * an(y) ≤ an(y)"
using an_case_split_left by blast
lemma an_mult_least_upper_bound:
"an(x) ≤ an(y) ∧ an(x) ≤ an(z) ⟷ an(x) ≤ an(y) * an(z)"
by (metis an_mult_idempotent an_mult_left_lower_bound an_mult_right_lower_bound order.trans mult_isotone)
lemma an_mult_left_divisibility:
"an(x) ≤ an(y) ⟷ (∃z . an(x) = an(y) * an(z))"
by (metis an_mult_commutative an_mult_left_lower_bound an_order)
lemma an_mult_right_divisibility:
"an(x) ≤ an(y) ⟷ (∃z . an(x) = an(z) * an(y))"
by (simp add: an_mult_commutative an_mult_left_divisibility)
lemma an_split_top:
"an(x * L) * x * top ≤ x * bot"
by (metis an_split mult_assoc mult_left_isotone mult_left_zero)
lemma an_n_L:
"an(n(x) * L) = an(x)"
using an_n_def n_an_def by auto
lemma an_galois:
"an(y) ≤ an(x) ⟷ n(x) * L ≤ y"
by (simp add: an_n_order n_galois)
lemma an_mult:
"an(x * n(y) * L) = an(x * y)"
by (metis an_n_L n_mult)
lemma n_mult_top:
"an(x * n(y) * top) = an(x * y)"
by (metis an_n_L n_mult_top)
lemma an_n_equal:
"an(x) = an(y) ⟷ n(x) = n(y)"
by (metis an_n_L n_an_def)
lemma an_top_L:
"an(x * top) = an(x * L)"
by (simp add: an_n_equal n_top_L)
lemma an_case_split_left_equal:
"an(z) * x = an(z) * y ⟹ n(z) * x = n(z) * y ⟹ x = y"
using an_complement case_split_left_equal by blast
lemma an_case_split_right_equal:
"x * an(z) = y * an(z) ⟹ x * n(z) = y * n(z) ⟹ x = y"
using an_complement case_split_right_equal by blast
lemma an_equal_complement:
"n(x) ⊔ an(y) = 1 ∧ n(x) * an(y) = bot ⟷ an(x) = an(y)"
by (metis sup_commute an_complement an_dist_sup mult_left_one mult_right_dist_sup n_complement_bot)
lemma n_equal_complement:
"n(x) ⊔ an(y) = 1 ∧ n(x) * an(y) = bot ⟷ n(x) = n(y)"
by (simp add: an_equal_complement an_n_equal)
lemma an_shunting:
"an(z) * x ≤ y ⟷ x ≤ y ⊔ n(z) * top"
apply (rule iffI)
apply (meson an_case_split_left le_supI1 split_sub)
by (metis sup_bot_right an_case_split_left an_complement_bot mult_assoc mult_left_dist_sup mult_left_zero mult_right_isotone order_refl order_trans)
lemma an_shunting_an:
"an(z) * an(x) ≤ an(y) ⟷ an(x) ≤ n(z) ⊔ an(y)"
apply (rule iffI)
apply (smt sup_ge1 sup_ge2 an_case_split_left n_an_mult_left_lower_bound order_trans)
by (metis sup_bot_left sup_ge2 an_case_split_left an_complement_bot mult_left_dist_sup mult_right_isotone order_trans)
lemma an_L_zero:
"an(x * L) * x = an(x * L) * x * bot"
by (metis an_complement_bot n_split_equal sup_monoid.add_0_right vector_bot_closed mult_assoc n_export_an)
lemma n_plus_complement_intro_n:
"n(x) ⊔ an(x) * n(y) = n(x) ⊔ n(y)"
by (metis sup_commute an_complement an_n_def mult_1_right n_sup_right_dist_mult n_an_mult_commutative)
lemma n_plus_complement_intro_an:
"n(x) ⊔ an(x) * an(y) = n(x) ⊔ an(y)"
by (metis an_n_def n_plus_complement_intro_n)
lemma an_plus_complement_intro_n:
"an(x) ⊔ n(x) * n(y) = an(x) ⊔ n(y)"
by (metis an_n_def n_an_def n_plus_complement_intro_n)
lemma an_plus_complement_intro_an:
"an(x) ⊔ n(x) * an(y) = an(x) ⊔ an(y)"
by (metis an_n_def an_plus_complement_intro_n)
lemma n_mult_complement_intro_n:
"n(x) * (an(x) ⊔ n(y)) = n(x) * n(y)"
by (simp add: mult_left_dist_sup n_complement_bot)
lemma n_mult_complement_intro_an:
"n(x) * (an(x) ⊔ an(y)) = n(x) * an(y)"
by (simp add: semiring.distrib_left n_complement_bot)
lemma an_mult_complement_intro_n:
"an(x) * (n(x) ⊔ n(y)) = an(x) * n(y)"
by (simp add: an_complement_bot mult_left_dist_sup)
lemma an_mult_complement_intro_an:
"an(x) * (n(x) ⊔ an(y)) = an(x) * an(y)"
by (simp add: an_complement_bot semiring.distrib_left)
lemma an_preserves_equation:
"an(y) * x ≤ x * an(y) ⟷ an(y) * x = an(y) * x * an(y)"
by (metis an_n_def n_preserves_equation)
lemma wnf_lemma_1:
"(n(p * L) * n(q * L) ⊔ an(p * L) * an(r * L)) * n(p * L) = n(p * L) * n(q * L)"
by (smt sup_commute an_n_def n_sup_left_absorb_mult n_sup_right_dist_mult n_export n_mult_commutative n_mult_complement_intro_n)
lemma wnf_lemma_2:
"(n(p * L) * n(q * L) ⊔ an(r * L) * an(q * L)) * n(q * L) = n(p * L) * n(q * L)"
by (metis an_mult_commutative n_mult_commutative wnf_lemma_1)
lemma wnf_lemma_3:
"(n(p * L) * n(r * L) ⊔ an(p * L) * an(q * L)) * an(p * L) = an(p * L) * an(q * L)"
by (metis an_n_def sup_commute wnf_lemma_1 n_an_def)
lemma wnf_lemma_4:
"(n(r * L) * n(q * L) ⊔ an(p * L) * an(q * L)) * an(q * L) = an(p * L) * an(q * L)"
by (metis an_mult_commutative n_mult_commutative wnf_lemma_3)
lemma wnf_lemma_5:
"n(p ⊔ q) * (n(q) * x ⊔ an(q) * y) = n(q) * x ⊔ an(q) * n(p) * y"
by (smt sup_bot_right mult_assoc mult_left_dist_sup n_an_mult_commutative n_complement_bot n_dist_sup n_mult_right_absorb_sup)
definition ani :: "'a ⇒ 'a"
where "ani x ≡ an(x) * L"
lemma ani_bot:
"ani(bot) = L"
using an_bot ani_def by auto
lemma ani_one:
"ani(1) = L"
using an_one ani_def by auto
lemma ani_L:
"ani(L) = bot"
by (simp add: an_L ani_def)
lemma ani_top:
"ani(top) = bot"
by (simp add: an_top ani_def)
lemma ani_complement:
"ani(x) ⊔ ni(x) = L"
by (metis an_complement ani_def mult_right_dist_sup n_top ni_def ni_top)
lemma ani_mult_zero:
"ani(x) = ani(x * bot)"
using ani_def an_mult_zero by auto
lemma ani_antitone:
"y ≤ x ⟹ ani(x) ≤ ani(y)"
by (simp add: an_antitone ani_def mult_left_isotone)
lemma ani_mult_left_upper_bound:
"ani(x * y) ≤ ani(x)"
by (simp add: an_mult_left_upper_bound ani_def mult_left_isotone)
lemma ani_involutive:
"ani(ani(x)) = ni(x)"
by (simp add: ani_def ni_def n_an_def)
lemma ani_below_L:
"ani(x) ≤ L"
using an_case_split_left ani_def by auto
lemma ani_left_zero:
"ani(x) * y = ani(x)"
by (simp add: ani_def L_left_zero mult_assoc)
lemma ani_top_L:
"ani(x * top) = ani(x * L)"
by (simp add: an_top_L ani_def)
lemma ani_ni_order:
"ani(x) ≤ ani(y) ⟷ ni(y) ≤ ni(x)"
by (metis an_n_L ani_antitone ani_def ani_involutive ni_def)
lemma ani_ni_equal:
"ani(x) = ani(y) ⟷ ni(x) = ni(y)"
by (metis ani_ni_order order.antisym order_refl)
lemma ni_ani:
"ni(ani(x)) = ani(x)"
using an_n_def ani_def ni_def by auto
lemma ani_ni:
"ani(ni(x)) = ani(x)"
by (simp add: an_n_L ani_def ni_def)
lemma ani_mult:
"ani(x * ni(y)) = ani(x * y)"
using ani_ni_equal ni_mult by blast
lemma ani_an_order:
"ani(x) ≤ ani(y) ⟷ an(x) ≤ an(y)"
using an_galois ani_ni_order ni_def ni_galois by auto
lemma ani_an_equal:
"ani(x) = ani(y) ⟷ an(x) = an(y)"
by (metis an_n_def ani_def)
lemma n_mult_ani:
"n(x) * ani(x) = bot"
by (metis an_L ani_L ani_def mult_assoc n_complement_bot)
lemma an_mult_ni:
"an(x) * ni(x) = bot"
by (metis an_n_def ani_def n_an_def n_mult_ani ni_def)
lemma n_mult_ni:
"n(x) * ni(x) = ni(x)"
by (metis n_export n_order ni_def ni_export order_refl)
lemma an_mult_ani:
"an(x) * ani(x) = ani(x)"
by (metis an_n_def ani_def n_mult_ni ni_def)
lemma ani_ni_meet:
"x ≤ ani(y) ⟹ x ≤ ni(y) ⟹ x = bot"
by (metis an_case_split_left an_mult_ni bot_unique mult_right_isotone n_mult_ani)
lemma ani_galois:
"ani(x) ≤ y ⟷ ni(x ⊔ y) = L"
apply (rule iffI)
apply (smt (z3) an_L an_mult_commutative an_mult_right_zero ani_def an_dist_sup ni_L ni_n_equal sup.absorb1 mult_assoc n_an_def n_complement_bot)
by (metis an_L an_galois an_mult_ni an_n_def an_shunting_an ani_def an_dist_sup an_export idempotent_bot_closed n_bot transitive_bot_closed)
lemma an_ani:
"an(ani(x)) = n(x)"
by (simp add: ani_def n_an_def)
lemma n_ani:
"n(ani(x)) = an(x)"
using an_n_def ani_def by auto
lemma an_ni:
"an(ni(x)) = an(x)"
by (simp add: an_n_L ni_def)
lemma ani_an:
"ani(an(x)) = L"
by (metis an_mult_right_zero an_mult_zero an_bot ani_def mult_left_one)
lemma ani_n:
"ani(n(x)) = L"
by (simp add: ani_an n_an_def)
lemma ni_an:
"ni(an(x)) = bot"
using an_L ani_an ani_def ni_n_bot n_an_def by force
lemma ani_mult_n:
"ani(x * n(y)) = ani(x)"
by (simp add: an_mult_n ani_def)
lemma ani_mult_an:
"ani(x * an(y)) = ani(x)"
by (simp add: an_mult_an ani_def)
lemma ani_export_n:
"ani(n(x) * y) = ani(x) ⊔ ani(y)"
by (simp add: an_export_n ani_def mult_right_dist_sup)
lemma ani_export_an:
"ani(an(x) * y) = ni(x) ⊔ ani(y)"
by (simp add: ani_def an_export ni_def semiring.distrib_right)
lemma ni_export_an:
"ni(an(x) * y) = an(x) * ni(y)"
by (simp add: an_mult_right_zero ni_split)
lemma ani_mult_top:
"ani(x * n(y) * top) = ani(x * y)"
using ani_def n_mult_top by auto
lemma ani_an_bot:
"ani(x) = bot ⟷ an(x) = bot"
using an_L ani_L ani_an_equal by force
lemma ani_an_L:
"ani(x) = L ⟷ an(x) = 1"
using an_bot ani_an_equal ani_bot by force
text ‹Theorem 21›
subclass tests
apply unfold_locales
apply (simp add: mult_assoc)
apply (simp add: an_mult_commutative an_uminus)
apply (smt an_sup_left_dist_mult an_export_n an_n_L an_uminus n_an_def n_complement_bot n_export)
apply (metis an_dist_sup an_n_def an_uminus n_an_def)
using an_complement_bot an_uminus n_an_def apply fastforce
apply (simp add: an_bot an_uminus)
using an_export_n an_mult an_uminus n_an_def apply fastforce
using an_order an_uminus apply force
by (simp add: less_le_not_le)
end
class an_itering = n_itering + an_semiring + while +
assumes while_circ_def: "p ⋆ y = (p * y)⇧∘ * -p"
begin
subclass test_itering
apply unfold_locales
by (rule while_circ_def)
lemma an_circ_left_unfold:
"an(x⇧∘) = an(x * x⇧∘)"
by (metis an_dist_sup an_one circ_left_unfold mult_left_one)
lemma an_circ_x_n_circ:
"an(x⇧∘) * x * n(x⇧∘) ≤ x * bot"
by (metis an_circ_left_unfold an_mult an_split mult_assoc n_mult_right_bot)
lemma an_circ_invariant:
"an(x⇧∘) * x ≤ x * an(x⇧∘)"
proof -
have 1: "an(x⇧∘) * x * an(x⇧∘) ≤ x * an(x⇧∘)"
by (metis an_case_split_left mult_assoc order_refl)
have "an(x⇧∘) * x * n(x⇧∘) ≤ x * an(x⇧∘)"
by (metis an_circ_x_n_circ order_trans mult_right_isotone bot_least)
thus ?thesis
using 1 an_case_split_right by blast
qed
lemma ani_circ:
"ani(x)⇧∘ = 1 ⊔ ani(x)"
by (simp add: ani_def mult_L_circ)
lemma ani_circ_left_unfold:
"ani(x⇧∘) = ani(x * x⇧∘)"
by (simp add: an_circ_left_unfold ani_def)
lemma an_circ_import:
"an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧∘ = an(y) * (an(y) * x)⇧∘"
by (metis an_n_def n_circ_import)
lemma preserves_L:
"preserves L (-p)"
using L_left_zero preserves_equation_test mult_assoc by force
end
class an_omega_algebra = n_omega_algebra_2 + an_semiring + while +
assumes while_Omega_def: "p ⋆ y = (p * y)⇧Ω * -p"
begin
lemma an_split_omega_omega:
"an(x⇧ω) * x⇧ω ≤ x⇧ω * bot"
by (meson an_antitone an_split mult_left_isotone omega_sub_vector order_trans)
lemma an_omega_below_an_star:
"an(x⇧ω) ≤ an(x⇧⋆)"
by (simp add: an_n_order n_star_below_n_omega)
lemma an_omega_below_an:
"an(x⇧ω) ≤ an(x)"
by (simp add: an_n_order n_below_n_omega)
lemma an_omega_induct:
"an(x * y ⊔ z) ≤ an(y) ⟹ an(x⇧ω ⊔ x⇧⋆ * z) ≤ an(y)"
by (simp add: an_n_order n_omega_induct)
lemma an_star_mult:
"an(y) ≤ an(x * y) ⟹ an(x⇧⋆ * y) = an(x⇧⋆) * an(y)"
by (metis an_dist_sup an_n_L an_n_order n_dist_sup n_star_mult)
lemma an_omega_mult:
"an(x⇧ω * y) = an(x⇧ω)"
by (simp add: an_n_equal n_omega_mult)
lemma an_star_left_unfold:
"an(x⇧⋆) = an(x * x⇧⋆)"
by (simp add: an_n_equal n_star_left_unfold)
lemma an_star_x_n_star:
"an(x⇧⋆) * x * n(x⇧⋆) ≤ x * bot"
by (metis an_n_L an_split n_mult n_mult_right_bot n_star_left_unfold mult_assoc)
lemma an_star_invariant:
"an(x⇧⋆) * x ≤ x * an(x⇧⋆)"
proof -
have 1: "an(x⇧⋆) * x * an(x⇧⋆) ≤ x * an(x⇧⋆)"
using an_case_split_left mult_assoc by auto
have "an(x⇧⋆) * x * n(x⇧⋆) ≤ x * an(x⇧⋆)"
by (metis an_star_x_n_star order_trans mult_right_isotone bot_least)
thus ?thesis
using 1 an_case_split_right by auto
qed
lemma n_an_star_unfold_invariant:
"n(an(x⇧⋆) * x⇧ω) ≤ an(x) * n(x * an(x⇧⋆) * x⇧ω)"
proof -
have "n(an(x⇧⋆) * x⇧ω) ≤ an(x)"
using an_star_left_unfold an_case_split_right an_mult_left_upper_bound n_export_an by fastforce
thus ?thesis
by (smt an_star_invariant le_iff_sup mult_assoc mult_right_dist_sup n_isotone n_order omega_unfold)
qed
lemma ani_omega_below_ani_star:
"ani(x⇧ω) ≤ ani(x⇧⋆)"
by (simp add: an_omega_below_an_star ani_an_order)
lemma ani_omega_below_ani:
"ani(x⇧ω) ≤ ani(x)"
by (simp add: an_omega_below_an ani_an_order)
lemma ani_star:
"ani(x)⇧⋆ = 1 ⊔ ani(x)"
by (simp add: ani_def mult_L_star)
lemma ani_omega:
"ani(x)⇧ω = ani(x) * L"
by (simp add: L_left_zero ani_def mult_L_omega mult_assoc)
lemma ani_omega_induct:
"ani(x * y ⊔ z) ≤ ani(y) ⟹ ani(x⇧ω ⊔ x⇧⋆ * z) ≤ ani(y)"
by (simp add: an_omega_induct ani_an_order)
lemma ani_omega_mult:
"ani(x⇧ω * y) = ani(x⇧ω)"
by (simp add: an_omega_mult ani_def)
lemma ani_star_left_unfold:
"ani(x⇧⋆) = ani(x * x⇧⋆)"
by (simp add: an_star_left_unfold ani_def)
lemma an_star_import:
"an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧⋆ = an(y) * (an(y) * x)⇧⋆"
by (metis an_n_def n_star_import)
lemma an_omega_export:
"an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧ω = (an(y) * x)⇧ω"
by (metis an_n_def n_omega_export)
lemma an_omega_import:
"an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧ω = an(y) * (an(y) * x)⇧ω"
by (simp add: an_mult_idempotent omega_import)
end
text ‹Theorem 22›
sublocale an_omega_algebra < nL_omega: an_itering where circ = Omega
apply unfold_locales
by (rule while_Omega_def)
context an_omega_algebra
begin
lemma preserves_star:
"nL_omega.preserves x (-p) ⟹ nL_omega.preserves (x⇧⋆) (-p)"
by (simp add: nL_omega.preserves_def star.circ_simulate)
end
end
Theory N_Semirings_Modal
section ‹Modal N-Semirings›
theory N_Semirings_Modal
imports N_Semirings_Boolean
begin
class n_diamond_semiring = n_semiring + diamond +
assumes ndiamond_def: "|x>y = n(x * y * L)"
begin
lemma diamond_x_bot:
"|x>bot = n(x)"
using n_mult_bot ndiamond_def mult_assoc by auto
lemma diamond_x_1:
"|x>1 = n(x * L)"
by (simp add: ndiamond_def)
lemma diamond_x_L:
"|x>L = n(x * L)"
by (simp add: L_left_zero ndiamond_def mult_assoc)
lemma diamond_x_top:
"|x>top = n(x * L)"
by (metis mult_assoc n_top_L ndiamond_def top_mult_top)
lemma diamond_x_n:
"|x>n(y) = n(x * y)"
by (simp add: n_mult ndiamond_def)
lemma diamond_bot_y:
"|bot>y = bot"
by (simp add: n_bot ndiamond_def)
lemma diamond_1_y:
"|1>y = n(y * L)"
by (simp add: ndiamond_def)
lemma diamond_1_n:
"|1>n(y) = n(y)"
by (simp add: diamond_1_y n_n_L)
lemma diamond_L_y:
"|L>y = 1"
by (simp add: L_left_zero n_L ndiamond_def)
lemma diamond_top_y:
"|top>y = 1"
by (metis sup_left_top sup_right_top diamond_L_y mult_right_dist_sup n_dist_sup n_top ndiamond_def)
lemma diamond_n_y:
"|n(x)>y = n(x) * n(y * L)"
by (simp add: n_export ndiamond_def mult_assoc)
lemma diamond_n_bot:
"|n(x)>bot = bot"
by (simp add: n_bot n_mult_right_bot ndiamond_def)
lemma diamond_n_1:
"|n(x)>1 = n(x)"
using diamond_1_n diamond_1_y diamond_x_1 by auto
lemma diamond_n_n:
"|n(x)>n(y) = n(x) * n(y)"
by (simp add: diamond_x_n n_export)
lemma diamond_n_n_same:
"|n(x)>n(x) = n(x)"
by (simp add: diamond_n_n n_mult_idempotent)
text ‹Theorem 23.1›
lemma diamond_left_dist_sup:
"|x ⊔ y>z = |x>z ⊔ |y>z"
by (simp add: mult_right_dist_sup n_dist_sup ndiamond_def)
text ‹Theorem 23.2›
lemma diamond_right_dist_sup:
"|x>(y ⊔ z) = |x>y ⊔ |x>z"
by (simp add: mult_left_dist_sup n_dist_sup ndiamond_def semiring.distrib_right)
text ‹Theorem 23.3›
lemma diamond_associative:
"|x * y>z = |x>(y * z)"
by (simp add: ndiamond_def mult_assoc)
text ‹Theorem 23.3›
lemma diamond_left_mult:
"|x * y>z = |x>|y>z"
using n_mult_ni ndiamond_def ni_def mult_assoc by auto
lemma diamond_right_mult:
"|x>(y * z) = |x>|y>z"
using diamond_associative diamond_left_mult by force
lemma diamond_n_export:
"|n(x) * y>z = n(x) * |y>z"
by (simp add: n_export ndiamond_def mult_assoc)
lemma diamond_diamond_export:
"||x>y>z = |x>y * |z>1"
using diamond_n_y ndiamond_def by auto
lemma diamond_left_isotone:
"x ≤ y ⟹ |x>z ≤ |y>z"
by (metis diamond_left_dist_sup le_iff_sup)
lemma diamond_right_isotone:
"y ≤ z ⟹ |x>y ≤ |x>z"
by (metis diamond_right_dist_sup le_iff_sup)
lemma diamond_isotone:
"w ≤ y ⟹ x ≤ z ⟹ |w>x ≤ |y>z"
by (meson diamond_left_isotone diamond_right_isotone order_trans)
definition ndiamond_L :: "'a ⇒ 'a ⇒ 'a" ("∥ _ » _" [50,90] 95)
where "∥x»y ≡ n(x * y) * L"
lemma ndiamond_to_L:
"∥x»y = |x>n(y) * L"
by (simp add: diamond_x_n ndiamond_L_def)
lemma ndiamond_from_L:
"|x>y = n(∥x»(y * L))"
by (simp add: n_n_L ndiamond_def mult_assoc ndiamond_L_def)
lemma diamond_L_ni:
"∥x»y = ni(x * y)"
by (simp add: ni_def ndiamond_L_def)
lemma diamond_L_associative:
"∥x * y»z = ∥x»(y * z)"
by (simp add: diamond_L_ni mult_assoc)
lemma diamond_L_left_mult:
"∥x * y»z = ∥x»∥y»z"
using diamond_L_associative diamond_L_ni ni_mult by auto
lemma diamond_L_right_mult:
"∥x»(y * z) = ∥x»∥y»z"
using diamond_L_associative diamond_L_left_mult by auto
lemma diamond_L_left_dist_sup:
"∥x ⊔ y»z = ∥x»z ⊔ ∥y»z"
by (simp add: diamond_L_ni mult_right_dist_sup ni_dist_sup)
lemma diamond_L_x_ni:
"∥x»ni(y) = ni(x * y)"
using n_mult_ni ni_def ndiamond_L_def by auto
lemma diamond_L_left_isotone:
"x ≤ y ⟹ ∥x»z ≤ ∥y»z"
using mult_left_isotone ni_def ni_isotone ndiamond_L_def by auto
lemma diamond_L_right_isotone:
"y ≤ z ⟹ ∥x»y ≤ ∥x»z"
using mult_right_isotone ni_def ni_isotone ndiamond_L_def by auto
lemma diamond_L_isotone:
"w ≤ y ⟹ x ≤ z ⟹ ∥w»x ≤ ∥y»z"
using diamond_L_ni mult_isotone ni_isotone by force
end
class n_box_semiring = n_diamond_semiring + an_semiring + box +
assumes nbox_def: "|x]y = an(x * an(y * L) * L)"
begin
text ‹Theorem 23.8›
lemma box_diamond:
"|x]y = an( |x>an(y * L) * L)"
by (simp add: an_n_L nbox_def ndiamond_def)
text ‹Theorem 23.4›
lemma diamond_box:
"|x>y = an( |x]an(y * L) * L)"
using n_an_def n_mult nbox_def ndiamond_def mult_assoc by force
lemma box_x_bot:
"|x]bot = an(x * L)"
by (simp add: an_bot nbox_def)
lemma box_x_1:
"|x]1 = an(x)"
using an_L an_mult_an nbox_def mult_assoc by auto
lemma box_x_L:
"|x]L = an(x)"
using box_x_1 L_left_zero nbox_def by auto
lemma box_x_top:
"|x]top = an(x)"
by (metis box_diamond box_x_1 box_x_bot diamond_top_y)
lemma box_x_n:
"|x]n(y) = an(x * an(y) * L)"
by (simp add: an_n_L nbox_def)
lemma box_x_an:
"|x]an(y) = an(x * y)"
using an_mult n_an_def nbox_def by auto
lemma box_bot_y:
"|bot]y = 1"
by (simp add: an_bot nbox_def)
lemma box_1_y:
"|1]y = n(y * L)"
by (simp add: n_an_def nbox_def)
lemma box_1_n:
"|1]n(y) = n(y)"
using box_1_y diamond_1_n diamond_1_y by auto
lemma box_1_an:
"|1]an(y) = an(y)"
by (simp add: box_x_an)
lemma box_L_y:
"|L]y = bot"
by (simp add: L_left_zero an_L nbox_def)
lemma box_top_y:
"|top]y = bot"
by (simp add: box_diamond an_L diamond_top_y)
lemma box_n_y:
"|n(x)]y = an(x) ⊔ n(y * L)"
using an_export_n n_an_def nbox_def mult_assoc by auto
lemma box_an_y:
"|an(x)]y = n(x) ⊔ n(y * L)"
by (metis an_n_def box_n_y n_an_def)
lemma box_n_bot:
"|n(x)]bot = an(x)"
by (simp add: box_x_bot an_n_L)
lemma box_an_bot:
"|an(x)]bot = n(x)"
by (simp add: box_x_bot n_an_def)
lemma box_n_1:
"|n(x)]1 = 1"
using box_x_1 ani_an_L ani_n by auto
lemma box_an_1:
"|an(x)]1 = 1"
using box_x_1 ani_an ani_an_L by fastforce
lemma box_n_n:
"|n(x)]n(y) = an(x) ⊔ n(y)"
using box_1_n box_1_y box_n_y by auto
lemma box_an_n:
"|an(x)]n(y) = n(x) ⊔ n(y)"
using box_x_n an_dist_sup n_an_def n_dist_sup by auto
lemma box_n_an:
"|n(x)]an(y) = an(x) ⊔ an(y)"
by (simp add: box_x_an an_export_n)
lemma box_an_an:
"|an(x)]an(y) = n(x) ⊔ an(y)"
by (simp add: box_x_an an_export)
lemma box_n_n_same:
"|n(x)]n(x) = 1"
by (simp add: box_n_n an_complement)
lemma box_an_an_same:
"|an(x)]an(x) = 1"
using box_an_bot an_bot an_complement_bot nbox_def by auto
text ‹Theorem 23.5›
lemma box_left_dist_sup:
"|x ⊔ y]z = |x]z * |y]z"
using an_dist_sup nbox_def semiring.distrib_right by auto
lemma box_right_dist_sup:
"|x](y ⊔ z) = an(x * an(y * L) * an(z * L) * L)"
by (simp add: an_dist_sup mult_right_dist_sup nbox_def mult_assoc)
lemma box_associative:
"|x * y]z = an(x * y * an(z * L) * L)"
by (simp add: nbox_def)
text ‹Theorem 23.7›
lemma box_left_mult:
"|x * y]z = |x]|y]z"
using box_x_an nbox_def mult_assoc by auto
lemma box_right_mult:
"|x](y * z) = an(x * an(y * z * L) * L)"
by (simp add: nbox_def)
text ‹Theorem 23.6›
lemma box_right_mult_n_n:
"|x](n(y) * n(z)) = |x]n(y) * |x]n(z)"
by (smt an_dist_sup an_export_n an_n_L mult_assoc mult_left_dist_sup mult_right_dist_sup nbox_def)
lemma box_right_mult_an_n:
"|x](an(y) * n(z)) = |x]an(y) * |x]n(z)"
by (metis an_n_def box_right_mult_n_n)
lemma box_right_mult_n_an:
"|x](n(y) * an(z)) = |x]n(y) * |x]an(z)"
by (simp add: box_right_mult_an_n box_x_an box_x_n an_mult_commutative n_an_mult_commutative)
lemma box_right_mult_an_an:
"|x](an(y) * an(z)) = |x]an(y) * |x]an(z)"
by (metis an_dist_sup box_x_an mult_left_dist_sup)
lemma box_n_export:
"|n(x) * y]z = an(x) ⊔ |y]z"
using box_left_mult box_n_an nbox_def by auto
lemma box_an_export:
"|an(x) * y]z = n(x) ⊔ |y]z"
using box_an_an box_left_mult nbox_def by auto
lemma box_left_antitone:
"y ≤ x ⟹ |x]z ≤ |y]z"
by (smt an_mult_commutative an_order box_diamond box_left_dist_sup le_iff_sup)
lemma box_right_isotone:
"y ≤ z ⟹ |x]y ≤ |x]z"
by (metis an_antitone mult_left_isotone mult_right_isotone nbox_def)
lemma box_antitone_isotone:
"y ≤ w ⟹ x ≤ z ⟹ |w]x ≤ |y]z"
by (meson box_left_antitone box_right_isotone order.trans)
definition nbox_L :: "'a ⇒ 'a ⇒ 'a" ("∥ _ ⟧ _" [50,90] 95)
where "∥x⟧y ≡ an(x * an(y) * L) * L"
lemma nbox_to_L:
"∥x⟧y = |x]n(y) * L"
by (simp add: box_x_n nbox_L_def)
lemma nbox_from_L:
"|x]y = n(∥x⟧(y * L))"
using an_n_def nbox_def nbox_L_def by auto
lemma diamond_x_an:
"|x>an(y) = n(x * an(y) * L)"
by (simp add: ndiamond_def)
lemma diamond_1_an:
"|1>an(y) = an(y)"
using box_1_an box_1_y diamond_1_y by auto
lemma diamond_an_y:
"|an(x)>y = an(x) * n(y * L)"
by (simp add: n_export_an ndiamond_def mult_assoc)
lemma diamond_an_bot:
"|an(x)>bot = bot"
by (simp add: an_mult_right_zero n_bot ndiamond_def)
lemma diamond_an_1:
"|an(x)>1 = an(x)"
using an_n_def diamond_x_1 by auto
lemma diamond_an_n:
"|an(x)>n(y) = an(x) * n(y)"
by (simp add: diamond_x_n n_export_an)
lemma diamond_n_an:
"|n(x)>an(y) = n(x) * an(y)"
using an_n_def diamond_n_y by auto
lemma diamond_an_an:
"|an(x)>an(y) = an(x) * an(y)"
using diamond_an_y an_n_def by auto
lemma diamond_an_an_same:
"|an(x)>an(x) = an(x)"
by (simp add: diamond_an_an an_mult_idempotent)
lemma diamond_an_export:
"|an(x) * y>z = an(x) * |y>z"
using diamond_an_an diamond_box diamond_left_mult by auto
lemma box_ani:
"|x]y = an(x * ani(y * L))"
by (simp add: ani_def nbox_def mult_assoc)
lemma box_x_n_ani:
"|x]n(y) = an(x * ani(y))"
by (simp add: box_x_n ani_def mult_assoc)
lemma box_L_ani:
"∥x⟧y = ani(x * ani(y))"
using box_x_n_ani ani_def nbox_to_L by auto
lemma box_L_left_mult:
"∥x * y⟧z = ∥x⟧∥y⟧z"
using an_mult n_an_def mult_assoc nbox_L_def by auto
lemma diamond_x_an_ani:
"|x>an(y) = n(x * ani(y))"
by (simp add: ani_def ndiamond_def mult_assoc)
lemma box_L_left_antitone:
"y ≤ x ⟹ ∥x⟧z ≤ ∥y⟧z"
by (simp add: box_L_ani ani_antitone mult_left_isotone)
lemma box_L_right_isotone:
"y ≤ z ⟹ ∥x⟧y ≤ ∥x⟧z"
using ani_antitone ani_def mult_right_isotone mult_assoc nbox_L_def by auto
lemma box_L_antitone_isotone:
"y ≤ w ⟹ x ≤ z ⟹ ∥w⟧x ≤ ∥y⟧z"
using ani_antitone ani_def mult_isotone mult_assoc nbox_L_def by force
end
class n_box_omega_algebra = n_box_semiring + an_omega_algebra
begin
lemma diamond_omega:
"|x⇧ω>y = |x⇧ω>z"
by (simp add: n_omega_mult ndiamond_def mult_assoc)
lemma box_omega:
"|x⇧ω]y = |x⇧ω]z"
by (metis box_diamond diamond_omega)
lemma an_box_omega_induct:
"|x]an(y) * n(z * L) ≤ an(y) ⟹ |x⇧ω ⊔ x⇧⋆]z ≤ an(y)"
by (smt an_dist_sup an_omega_induct an_omega_mult box_left_dist_sup box_x_an mult_assoc n_an_def nbox_def)
lemma n_box_omega_induct:
"|x]n(y) * n(z * L) ≤ n(y) ⟹ |x⇧ω ⊔ x⇧⋆]z ≤ n(y)"
by (simp add: an_box_omega_induct n_an_def)
lemma an_box_omega_induct_an:
"|x]an(y) * an(z) ≤ an(y) ⟹ |x⇧ω ⊔ x⇧⋆]an(z) ≤ an(y)"
using an_box_omega_induct an_n_def by auto
text ‹Theorem 23.13›
lemma n_box_omega_induct_n:
"|x]n(y) * n(z) ≤ n(y) ⟹ |x⇧ω ⊔ x⇧⋆]n(z) ≤ n(y)"
using an_box_omega_induct_an n_an_def by force
lemma n_diamond_omega_induct:
"n(y) ≤ |x>n(y) ⊔ n(z * L) ⟹ n(y) ≤ |x⇧ω ⊔ x⇧⋆>z"
using diamond_x_n mult_right_dist_sup n_dist_sup n_omega_induct n_omega_mult ndiamond_def mult_assoc by force
lemma an_diamond_omega_induct:
"an(y) ≤ |x>an(y) ⊔ n(z * L) ⟹ an(y) ≤ |x⇧ω ⊔ x⇧⋆>z"
by (metis n_diamond_omega_induct an_n_def)
text ‹Theorem 23.9›
lemma n_diamond_omega_induct_n:
"n(y) ≤ |x>n(y) ⊔ n(z) ⟹ n(y) ≤ |x⇧ω ⊔ x⇧⋆>n(z)"
using box_1_n box_1_y n_diamond_omega_induct by auto
lemma an_diamond_omega_induct_an:
"an(y) ≤ |x>an(y) ⊔ an(z) ⟹ an(y) ≤ |x⇧ω ⊔ x⇧⋆>an(z)"
using an_diamond_omega_induct an_n_def by auto
lemma box_segerberg_an:
"|x⇧ω ⊔ x⇧⋆]an(y) = an(y) * |x⇧ω ⊔ x⇧⋆](n(y) ⊔ |x]an(y))"
proof (rule order.antisym)
have "|x⇧ω ⊔ x⇧⋆]an(y) ≤ |x⇧ω ⊔ x⇧⋆]|x]an(y)"
by (smt box_left_dist_sup box_left_mult box_omega sup_right_isotone box_left_antitone mult_right_dist_sup star.right_plus_below_circ)
hence "|x⇧ω ⊔ x⇧⋆]an(y) ≤ |x⇧ω ⊔ x⇧⋆](n(y) ⊔ |x]an(y))"
using box_right_isotone order_lesseq_imp sup.cobounded2 by blast
thus"|x⇧ω ⊔ x⇧⋆]an(y) ≤ an(y) * |x⇧ω ⊔ x⇧⋆](n(y) ⊔ |x]an(y))"
by (metis le_sup_iff box_1_an box_left_antitone order_refl star_left_unfold_equal an_mult_least_upper_bound nbox_def)
next
have "an(y) * |x](n(y) ⊔ |x⇧ω ⊔ x⇧⋆]an(y)) * (n(y) ⊔ |x]an(y)) = |x]( |x⇧ω ⊔ x⇧⋆]an(y) * an(y)) * an(y)"
by (smt sup_bot_left an_export an_mult_commutative box_right_mult_an_an mult_assoc mult_right_dist_sup n_complement_bot nbox_def)
hence 1: "an(y) * |x](n(y) ⊔ |x⇧ω ⊔ x⇧⋆]an(y)) * (n(y) ⊔ |x]an(y)) ≤ n(y) ⊔ |x⇧ω ⊔ x⇧⋆]an(y)"
by (smt sup_assoc sup_commute sup_ge2 box_1_an box_left_dist_sup box_left_mult mult_left_dist_sup omega_unfold star_left_unfold_equal star.circ_plus_one)
have "n(y) * |x](n(y) ⊔ |x⇧ω ⊔ x⇧⋆]an(y)) * (n(y) ⊔ |x]an(y)) ≤ n(y) ⊔ |x⇧ω ⊔ x⇧⋆]an(y)"
by (smt sup_ge1 an_n_def mult_left_isotone n_an_mult_left_lower_bound n_mult_left_absorb_sup nbox_def order_trans)
thus "an(y) * |x⇧ω ⊔ x⇧⋆](n(y) ⊔ |x]an(y)) ≤ |x⇧ω ⊔ x⇧⋆]an(y)"
using 1 by (smt an_case_split_left an_shunting_an mult_assoc n_box_omega_induct_n n_dist_sup nbox_def nbox_from_L)
qed
text ‹Theorem 23.16›
lemma box_segerberg_n:
"|x⇧ω ⊔ x⇧⋆]n(y) = n(y) * |x⇧ω ⊔ x⇧⋆](an(y) ⊔ |x]n(y))"
using box_segerberg_an an_n_def n_an_def by force
lemma diamond_segerberg_an:
"|x⇧ω ⊔ x⇧⋆>an(y) = an(y) ⊔ |x⇧ω ⊔ x⇧⋆>(n(y) * |x>an(y))"
by (smt an_export an_n_L box_diamond box_segerberg_an diamond_box mult_assoc n_an_def)
text ‹Theorem 23.12›
lemma diamond_segerberg_n:
"|x⇧ω ⊔ x⇧⋆>n(y) = n(y) ⊔ |x⇧ω ⊔ x⇧⋆>(an(y) * |x>n(y))"
using diamond_segerberg_an an_n_L n_an_def by auto
text ‹Theorem 23.11›
lemma diamond_star_unfold_n:
"|x⇧⋆>n(y) = n(y) ⊔ |an(y) * x>|x⇧⋆>n(y)"
proof -
have "|x⇧⋆>n(y) = n(y) ⊔ n(y) * |x * x⇧⋆>n(y) ⊔ |an(y) * x * x⇧⋆>n(y)"
by (smt sup_assoc sup_commute sup_bot_right an_complement an_complement_bot diamond_an_n diamond_left_dist_sup diamond_n_export diamond_n_n_same mult_assoc mult_left_one mult_right_dist_sup star_left_unfold_equal)
thus ?thesis
by (metis diamond_left_mult diamond_x_n n_sup_left_absorb_mult)
qed
lemma diamond_star_unfold_an:
"|x⇧⋆>an(y) = an(y) ⊔ |n(y) * x>|x⇧⋆>an(y)"
by (metis an_n_def diamond_star_unfold_n n_an_def)
text ‹Theorem 23.15›
lemma box_star_unfold_n:
"|x⇧⋆]n(y) = n(y) * |n(y) * x]|x⇧⋆]n(y)"
by (smt an_export an_n_L box_diamond diamond_box diamond_star_unfold_an n_an_def n_export)
lemma box_star_unfold_an:
"|x⇧⋆]an(y) = an(y) * |an(y) * x]|x⇧⋆]an(y)"
by (metis an_n_def box_star_unfold_n)
text ‹Theorem 23.10›
lemma diamond_omega_unfold_n:
"|x⇧ω ⊔ x⇧⋆>n(y) = n(y) ⊔ |an(y) * x>|x⇧ω ⊔ x⇧⋆>n(y)"
by (smt sup_assoc sup_commute diamond_an_export diamond_left_dist_sup diamond_right_dist_sup diamond_star_unfold_n diamond_x_n n_omega_mult n_plus_complement_intro_n omega_unfold)
lemma diamond_omega_unfold_an:
"|x⇧ω ⊔ x⇧⋆>an(y) = an(y) ⊔ |n(y) * x>|x⇧ω ⊔ x⇧⋆>an(y)"
by (metis an_n_def diamond_omega_unfold_n n_an_def)
text ‹Theorem 23.14›
lemma box_omega_unfold_n:
"|x⇧ω ⊔ x⇧⋆]n(y) = n(y) * |n(y) * x]|x⇧ω ⊔ x⇧⋆]n(y)"
by (smt an_export an_n_L box_diamond diamond_box diamond_omega_unfold_an n_an_def n_export)
lemma box_omega_unfold_an:
"|x⇧ω ⊔ x⇧⋆]an(y) = an(y) * |an(y) * x]|x⇧ω ⊔ x⇧⋆]an(y)"
by (metis an_n_def box_omega_unfold_n)
lemma box_cut_iteration_an:
"|x⇧ω ⊔ x⇧⋆]an(y) = |(an(y) * x)⇧ω ⊔ (an(y) * x)⇧⋆]an(y)"
apply (rule order.antisym)
apply (meson semiring.add_mono an_case_split_left box_left_antitone omega_isotone order_refl star.circ_isotone)
by (smt (z3) an_box_omega_induct_an an_mult_commutative box_omega_unfold_an nbox_def order_refl)
lemma box_cut_iteration_n:
"|x⇧ω ⊔ x⇧⋆]n(y) = |(n(y) * x)⇧ω ⊔ (n(y) * x)⇧⋆]n(y)"
using box_cut_iteration_an n_an_def by auto
lemma diamond_cut_iteration_an:
"|x⇧ω ⊔ x⇧⋆>an(y) = |(n(y) * x)⇧ω ⊔ (n(y) * x)⇧⋆>an(y)"
using box_cut_iteration_n diamond_box n_an_def by auto
lemma diamond_cut_iteration_n:
"|x⇧ω ⊔ x⇧⋆>n(y) = |(an(y) * x)⇧ω ⊔ (an(y) * x)⇧⋆>n(y)"
using box_cut_iteration_an an_n_L diamond_box by auto
lemma ni_diamond_omega_induct:
"ni(y) ≤ ∥x»ni(y) ⊔ ni(z) ⟹ ni(y) ≤ ∥x⇧ω ⊔ x⇧⋆»z"
by (metis diamond_L_left_dist_sup diamond_L_x_ni diamond_L_ni ni_dist_sup ni_omega_induct ni_omega_mult)
lemma ani_diamond_omega_induct:
"ani(y) ≤ ∥x»ani(y) ⊔ ni(z) ⟹ ani(y) ≤ ∥x⇧ω ⊔ x⇧⋆»z"
by (metis ni_ani ni_diamond_omega_induct)
lemma n_diamond_omega_L:
"|n(x⇧ω) * L>y = |x⇧ω>y"
using L_left_zero mult_1_right n_L n_export n_omega_mult ndiamond_def mult_assoc by auto
lemma n_diamond_loop:
"|x⇧Ω>y = |x⇧ω ⊔ x⇧⋆>y"
by (metis Omega_def diamond_left_dist_sup n_diamond_omega_L)
text ‹Theorem 24.1›
lemma cut_iteration_loop:
"|x⇧Ω>n(y) = |(an(y) * x)⇧Ω>n(y)"
using diamond_cut_iteration_n n_diamond_loop by auto
lemma cut_iteration_while_loop:
"|x⇧Ω>n(y) = |(an(y) * x)⇧Ω * n(y)>n(y)"
using cut_iteration_loop diamond_left_mult diamond_n_n_same by auto
text ‹Theorem 24.1›
lemma cut_iteration_while_loop_2:
"|x⇧Ω>n(y) = |an(y) ⋆ x>n(y)"
by (metis cut_iteration_while_loop an_uminus n_an_def while_Omega_def)
lemma modal_while:
assumes "-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r"
shows "-p ≤ |n((-q * x)⇧ω) * L ⊔ (-q * x)⇧⋆ * --q>(-r)"
proof -
have 1: "--q * -p ≤ |-q * x>(-p) ⊔ --q * -r"
using assms mult_right_isotone sup.coboundedI2 tests_dual.sup_complement_intro by auto
have "-q * -p = n(-q * -q * -p * L)"
using an_uminus n_export_an mult_assoc mult_1_right n_L tests_dual.sup_idempotent by auto
also have "... ≤ n(-q * x * -p * L)"
by (metis assms n_isotone mult_right_isotone mult_assoc)
also have "... ≤ |-q * x>(-p) ⊔ --q * -r"
by (simp add: ndiamond_def)
finally have "-p ≤ |-q * x>(-p) ⊔ --q * -r"
using 1 by (smt sup_assoc le_iff_sup tests_dual.inf_cases sub_comm)
thus ?thesis
by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc n_n_L n_omega_mult ndiamond_def sub_mult_closed)
qed
lemma modal_while_loop:
"-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r ⟹ -p ≤ |(-q * x)⇧Ω * --q>(-r)"
by (metis L_left_zero Omega_def modal_while mult_assoc mult_right_dist_sup)
text ‹Theorem 24.2›
lemma modal_while_loop_2:
"-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r ⟹ -p ≤ |-q ⋆ x>(-r)"
by (simp add: while_Omega_def modal_while_loop)
lemma modal_while_2:
assumes "-p * L ≤ x * -p * L"
shows "-p ≤ |n((-q * x)⇧ω) * L ⊔ (-q * x)⇧⋆ * --q>(--q)"
proof -
have "-p ≤ |-q * x>(-p) ⊔ --q"
by (smt (verit, del_insts) assms an_uminus tests_dual.double_negation n_an_def n_isotone ndiamond_def diamond_an_export sup_assoc sup_commute le_iff_sup tests_dual.inf_complement_intro)
thus ?thesis
by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc tests_dual.sup_idempotent n_n_L n_omega_mult ndiamond_def)
qed
end
class n_modal_omega_algebra = n_box_omega_algebra +
assumes n_star_induct: "n(x * y) ≤ n(y) ⟶ n(x⇧⋆ * y) ≤ n(y)"
begin
lemma n_star_induct_sup:
"n(z ⊔ x * y) ≤ n(y) ⟹ n(x⇧⋆ * z) ≤ n(y)"
by (metis an_dist_sup an_mult_least_upper_bound an_n_order n_mult_right_upper_bound n_star_induct star_L_split)
lemma n_star_induct_star:
"n(x * y) ≤ n(y) ⟹ n(x⇧⋆) ≤ n(y)"
using n_star_induct n_star_mult by auto
lemma n_star_induct_iff:
"n(x * y) ≤ n(y) ⟷ n(x⇧⋆ * y) ≤ n(y)"
by (metis mult_left_isotone n_isotone n_star_induct order_trans star.circ_increasing)
lemma n_star_bot:
"n(x) = bot ⟷ n(x⇧⋆) = bot"
by (metis sup_bot_right le_iff_sup mult_1_right n_one n_star_induct_iff)
lemma n_diamond_star_induct:
"|x>n(y) ≤ n(y) ⟹ |x⇧⋆>n(y) ≤ n(y)"
by (simp add: diamond_x_n n_star_induct)
lemma n_diamond_star_induct_sup:
"|x>n(y) ⊔ n(z) ≤ n(y) ⟹ |x⇧⋆>n(z) ≤ n(y)"
by (simp add: diamond_x_n n_dist_sup n_star_induct_sup)
lemma n_diamond_star_induct_iff:
"|x>n(y) ≤ n(y) ⟷ |x⇧⋆>n(y) ≤ n(y)"
using diamond_x_n n_star_induct_iff by auto
lemma an_star_induct:
"an(y) ≤ an(x * y) ⟹ an(y) ≤ an(x⇧⋆ * y)"
using an_n_order n_star_induct by auto
lemma an_star_induct_sup:
"an(y) ≤ an(z ⊔ x * y) ⟹ an(y) ≤ an(x⇧⋆ * z)"
using an_n_order n_star_induct_sup by auto
lemma an_star_induct_star:
"an(y) ≤ an(x * y) ⟹ an(y) ≤ an(x⇧⋆)"
by (simp add: an_n_order n_star_induct_star)
lemma an_star_induct_iff:
"an(y) ≤ an(x * y) ⟷ an(y) ≤ an(x⇧⋆ * y)"
using an_n_order n_star_induct_iff by auto
lemma an_star_one:
"an(x) = 1 ⟷ an(x⇧⋆) = 1"
by (metis an_n_equal an_bot n_star_bot n_bot)
lemma an_box_star_induct:
"an(y) ≤ |x]an(y) ⟹ an(y) ≤ |x⇧⋆]an(y)"
by (simp add: an_star_induct box_x_an)
lemma an_box_star_induct_sup:
"an(y) ≤ |x]an(y) * an(z) ⟹ an(y) ≤ |x⇧⋆]an(z)"
by (simp add: an_star_induct_sup an_dist_sup an_mult_commutative box_x_an)
lemma an_box_star_induct_iff:
"an(y) ≤ |x]an(y) ⟷ an(y) ≤ |x⇧⋆]an(y)"
using an_star_induct_iff box_x_an by auto
lemma box_star_segerberg_an:
"|x⇧⋆]an(y) = an(y) * |x⇧⋆](n(y) ⊔ |x]an(y))"
proof (rule order.antisym)
show "|x⇧⋆]an(y) ≤ an(y) * |x⇧⋆](n(y) ⊔ |x]an(y))"
by (smt (verit) sup_ge2 box_1_an box_left_dist_sup box_left_mult box_right_isotone mult_right_isotone star.circ_right_unfold)
next
have "an(y) * |x⇧⋆](n(y) ⊔ |x]an(y)) ≤ an(y) * |x]an(y)"
by (metis sup_bot_left an_complement_bot box_an_an box_left_antitone box_x_an mult_left_dist_sup mult_left_one mult_right_isotone star.circ_reflexive)
thus "an(y) * |x⇧⋆](n(y) ⊔ |x]an(y)) ≤ |x⇧⋆]an(y)"
by (smt an_box_star_induct_sup an_case_split_left an_dist_sup an_mult_least_upper_bound box_left_antitone box_left_mult box_right_mult_an_an star.left_plus_below_circ nbox_def)
qed
lemma box_star_segerberg_n:
"|x⇧⋆]n(y) = n(y) * |x⇧⋆](an(y) ⊔ |x]n(y))"
using box_star_segerberg_an an_n_def n_an_def by auto
lemma diamond_segerberg_an:
"|x⇧⋆>an(y) = an(y) ⊔ |x⇧⋆>(n(y) * |x>an(y))"
by (smt an_export an_n_L box_diamond box_star_segerberg_an diamond_box mult_assoc n_an_def)
lemma diamond_star_segerberg_n:
"|x⇧⋆>n(y) = n(y) ⊔ |x⇧⋆>(an(y) * |x>n(y))"
using an_n_def diamond_segerberg_an n_an_def by auto
lemma box_cut_star_iteration_an:
"|x⇧⋆]an(y) = |(an(y) * x)⇧⋆]an(y)"
by (smt an_box_star_induct_sup an_mult_commutative an_mult_complement_intro_an order.antisym box_an_export box_star_unfold_an nbox_def order_refl)
lemma box_cut_star_iteration_n:
"|x⇧⋆]n(y) = |(n(y) * x)⇧⋆]n(y)"
using box_cut_star_iteration_an n_an_def by auto
lemma diamond_cut_star_iteration_an:
"|x⇧⋆>an(y) = |(n(y) * x)⇧⋆>an(y)"
using box_cut_star_iteration_an diamond_box n_an_def by auto
lemma diamond_cut_star_iteration_n:
"|x⇧⋆>n(y) = |(an(y) * x)⇧⋆>n(y)"
using box_cut_star_iteration_an an_n_L diamond_box by auto
lemma ni_star_induct:
"ni(x * y) ≤ ni(y) ⟹ ni(x⇧⋆ * y) ≤ ni(y)"
using n_star_induct ni_n_order by auto
lemma ni_star_induct_sup:
"ni(z ⊔ x * y) ≤ ni(y) ⟹ ni(x⇧⋆ * z) ≤ ni(y)"
by (simp add: ni_n_order n_star_induct_sup)
lemma ni_star_induct_star:
"ni(x * y) ≤ ni(y) ⟹ ni(x⇧⋆) ≤ ni(y)"
using ni_n_order n_star_induct_star by auto
lemma ni_star_induct_iff:
"ni(x * y) ≤ ni(y) ⟷ ni(x⇧⋆ * y) ≤ ni(y)"
using ni_n_order n_star_induct_iff by auto
lemma ni_star_bot:
"ni(x) = bot ⟷ ni(x⇧⋆) = bot"
using ni_n_bot n_star_bot by auto
lemma ni_diamond_star_induct:
"∥x»ni(y) ≤ ni(y) ⟹ ∥x⇧⋆»ni(y) ≤ ni(y)"
by (simp add: diamond_L_x_ni ni_star_induct)
lemma ni_diamond_star_induct_sup:
"∥x»ni(y) ⊔ ni(z) ≤ ni(y) ⟹ ∥x⇧⋆»ni(z) ≤ ni(y)"
by (simp add: diamond_L_x_ni ni_dist_sup ni_star_induct_sup)
lemma ni_diamond_star_induct_iff:
"∥x»ni(y) ≤ ni(y) ⟷ ∥x⇧⋆»ni(y) ≤ ni(y)"
using diamond_L_x_ni ni_star_induct_iff by auto
lemma ani_star_induct:
"ani(y) ≤ ani(x * y) ⟹ ani(y) ≤ ani(x⇧⋆ * y)"
using an_star_induct ani_an_order by blast
lemma ani_star_induct_sup:
"ani(y) ≤ ani(z ⊔ x * y) ⟹ ani(y) ≤ ani(x⇧⋆ * z)"
by (simp add: an_star_induct_sup ani_an_order)
lemma ani_star_induct_star:
"ani(y) ≤ ani(x * y) ⟹ ani(y) ≤ ani(x⇧⋆)"
using an_star_induct_star ani_an_order by auto
lemma ani_star_induct_iff:
"ani(y) ≤ ani(x * y) ⟷ ani(y) ≤ ani(x⇧⋆ * y)"
using an_star_induct_iff ani_an_order by auto
lemma ani_star_L:
"ani(x) = L ⟷ ani(x⇧⋆) = L"
using an_star_one ani_an_L by auto
lemma ani_box_star_induct:
"ani(y) ≤ ∥x⟧ani(y) ⟹ ani(y) ≤ ∥x⇧⋆⟧ani(y)"
by (metis an_ani ani_def ani_star_induct_iff n_ani box_L_ani)
lemma ani_box_star_induct_iff:
"ani(y) ≤ ∥x⟧ani(y) ⟷ ani(y) ≤ ∥x⇧⋆⟧ani(y)"
using ani_box_star_induct box_L_left_antitone order_lesseq_imp star.circ_increasing by blast
lemma ani_box_star_induct_sup:
"ani(y) ≤ ∥x⟧ani(y) ⟹ ani(y) ≤ ani(z) ⟹ ani(y) ≤ ∥x⇧⋆⟧ani(z)"
by (meson ani_box_star_induct_iff box_L_right_isotone order_trans)
end
end
Theory Approximation
section ‹Approximation›
theory Approximation
imports Stone_Kleene_Relation_Algebras.Iterings
begin
class apx =
fixes apx :: "'a ⇒ 'a ⇒ bool" (infix "⊑" 50)
class apx_order = apx +
assumes apx_reflexive: "x ⊑ x"
assumes apx_antisymmetric: "x ⊑ y ∧ y ⊑ x ⟶ x = y"
assumes apx_transitive: "x ⊑ y ∧ y ⊑ z ⟶ x ⊑ z"
sublocale apx_order < apx: order where less_eq = apx and less = "λx y . x ⊑ y ∧ ¬ y ⊑ x"
apply unfold_locales
apply simp
apply (rule apx_reflexive)
using apx_transitive apply blast
by (simp add: apx_antisymmetric)
context apx_order
begin
abbreviation the_apx_least_fixpoint :: "('a ⇒ 'a) ⇒ 'a" ("κ _" [201] 200) where "κ f ≡ apx.the_least_fixpoint f"
abbreviation the_apx_least_prefixpoint :: "('a ⇒ 'a) ⇒ 'a" ("pκ _" [201] 200) where "pκ f ≡ apx.the_least_prefixpoint f"
definition is_apx_meet :: "'a ⇒ 'a ⇒ 'a ⇒ bool" where "is_apx_meet x y z ≡ z ⊑ x ∧ z ⊑ y ∧ (∀w . w ⊑ x ∧ w ⊑ y ⟶ w ⊑ z)"
definition has_apx_meet :: "'a ⇒ 'a ⇒ bool" where "has_apx_meet x y ≡ ∃z . is_apx_meet x y z"
definition the_apx_meet :: "'a ⇒ 'a ⇒ 'a" (infixl "△" 66) where "x △ y ≡ THE z . is_apx_meet x y z"
lemma apx_meet_unique:
"has_apx_meet x y ⟹ ∃!z . is_apx_meet x y z"
by (meson apx_antisymmetric has_apx_meet_def is_apx_meet_def)
lemma apx_meet:
assumes "has_apx_meet x y"
shows "is_apx_meet x y (x △ y)"
proof -
have "is_apx_meet x y (THE z . is_apx_meet x y z)"
by (metis apx_meet_unique assms theI)
thus ?thesis
by (simp add: the_apx_meet_def)
qed
lemma apx_greatest_lower_bound:
"has_apx_meet x y ⟹ (w ⊑ x ∧ w ⊑ y ⟷ w ⊑ x △ y)"
by (meson apx_meet apx_transitive is_apx_meet_def)
lemma apx_meet_same:
"is_apx_meet x y z ⟹ z = x △ y"
using apx_meet apx_meet_unique has_apx_meet_def by blast
lemma apx_meet_char:
"is_apx_meet x y z ⟷ has_apx_meet x y ∧ z = x △ y"
using apx_meet_same has_apx_meet_def by auto
end
class apx_biorder = apx_order + order
begin
lemma mu_below_kappa:
"has_least_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ μ f ≤ κ f"
using apx.mu_unfold is_least_fixpoint_def least_fixpoint by auto
lemma kappa_below_nu:
"has_greatest_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ≤ ν f"
by (meson apx.mu_unfold greatest_fixpoint is_greatest_fixpoint_def)
lemma kappa_apx_below_mu:
"has_least_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ⊑ μ f"
using apx.is_least_fixpoint_def apx.least_fixpoint mu_unfold by auto
lemma kappa_apx_below_nu:
"has_greatest_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ⊑ ν f"
by (metis apx.is_least_fixpoint_def apx.least_fixpoint nu_unfold)
end
class apx_semiring = apx_biorder + idempotent_left_semiring + L +
assumes apx_L_least: "L ⊑ x"
assumes sup_apx_left_isotone: "x ⊑ y ⟶ x ⊔ z ⊑ y ⊔ z"
assumes mult_apx_left_isotone: "x ⊑ y ⟶ x * z ⊑ y * z"
assumes mult_apx_right_isotone: "x ⊑ y ⟶ z * x ⊑ z * y"
begin
lemma sup_apx_right_isotone:
"x ⊑ y ⟹ z ⊔ x ⊑ z ⊔ y"
by (simp add: sup_apx_left_isotone sup_commute)
lemma sup_apx_isotone:
"w ⊑ y ⟹ x ⊑ z ⟹ w ⊔ x ⊑ y ⊔ z"
by (meson apx_transitive sup_apx_left_isotone sup_apx_right_isotone)
lemma mult_apx_isotone:
"w ⊑ y ⟹ x ⊑ z ⟹ w * x ⊑ y * z"
by (meson apx_transitive mult_apx_left_isotone mult_apx_right_isotone)
lemma affine_apx_isotone:
"apx.isotone (λx . y * x ⊔ z)"
by (simp add: apx.isotone_def mult_apx_right_isotone sup_apx_left_isotone)
end
end
Theory Recursion_Strict
section ‹Strict Recursion›
theory Recursion_Strict
imports N_Semirings Approximation
begin
class semiring_apx = n_semiring + apx +
assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
begin
lemma apx_n_order_reverse:
"y ⊑ x ⟹ n(x) ≤ n(y)"
by (metis apx_def le_iff_sup n_sup_left_absorb_mult n_dist_sup n_export)
lemma apx_n_order:
"x ⊑ y ⟹ y ⊑ x ⟹ n(x) = n(y)"
by (simp add: apx_n_order_reverse order.antisym)
lemma apx_transitive:
assumes "x ⊑ y"
and "y ⊑ z"
shows "x ⊑ z"
proof -
have "n(y) * L ≤ n(x) * L"
by (simp add: apx_n_order_reverse assms(1) mult_left_isotone)
hence 1: "x ≤ z ⊔ n(x) * L"
by (smt assms sup_assoc sup_right_divisibility apx_def le_iff_sup)
have "z ≤ x ⊔ n(x) * top ⊔ n(x ⊔ n(x) * top) * top"
by (smt (verit) assms sup_left_isotone order_refl sup_assoc sup_mono apx_def mult_left_isotone n_isotone order_trans)
also have "... = x ⊔ n(x) * top"
by (simp add: n_dist_sup n_export n_sup_left_absorb_mult)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
text ‹Theorem 16.1›
subclass apx_biorder
apply unfold_locales
apply (simp add: apx_def)
apply (smt (verit) order.antisym le_sup_iff apx_def eq_refl le_iff_sup n_galois apx_n_order)
using apx_transitive by blast
lemma sup_apx_left_isotone:
assumes "x ⊑ y"
shows "x ⊔ z ⊑ y ⊔ z"
proof -
have "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "z ⊔ x ≤ z ⊔ y ⊔ n(z ⊔ x) * L ∧ z ⊔ y ≤ z ⊔ x ⊔ n(z ⊔ x) * top"
by (metis sup_assoc sup_right_isotone mult_right_sub_dist_sup_right n_dist_sup order_trans)
thus ?thesis
by (simp add: apx_def sup_commute)
qed
lemma mult_apx_left_isotone:
assumes "x ⊑ y"
shows "x * z ⊑ y * z"
proof -
have "x ≤ y ⊔ n(x) * L"
using assms apx_def by auto
hence "x * z ≤ y * z ⊔ n(x) * L"
by (smt (verit, ccfv_threshold) L_left_zero mult_left_isotone semiring.distrib_right mult_assoc)
hence 1: "x * z ≤ y * z ⊔ n(x * z) * L"
by (meson mult_left_isotone n_mult_left_upper_bound order_lesseq_imp sup_mono)
have "y * z ≤ x * z ⊔ n(x) * top * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
hence "y * z ≤ x * z ⊔ n(x * z) * top"
using mult_isotone n_mult_left_upper_bound order.trans sup_right_isotone top_greatest mult_assoc by presburger
thus ?thesis
using 1 by (simp add: apx_def)
qed
lemma mult_apx_right_isotone:
assumes "x ⊑ y"
shows "z * x ⊑ z * y"
proof -
have "x ≤ y ⊔ n(x) * L"
using assms apx_def by auto
hence 1: "z * x ≤ z * y ⊔ n(z * x) * L"
by (smt sup_assoc sup_ge1 sup_bot_right mult_assoc mult_left_dist_sup mult_right_isotone n_L_split)
have "y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "z * y ≤ z * x ⊔ z * n(x) * top"
by (smt mult_assoc mult_left_dist_sup mult_right_isotone)
also have "... ≤ z * x ⊔ n(z * x) * top"
by (smt (verit) sup_assoc le_supI le_sup_iff sup_ge1 sup_bot_right mult_left_dist_sup n_L_split n_top_split order_trans)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
text ‹Theorem 16.1 and Theorem 16.2›
subclass apx_semiring
apply unfold_locales
apply (metis sup_right_top sup_ge2 apx_def mult_left_one n_L top_greatest)
apply (simp add: sup_apx_left_isotone)
apply (simp add: mult_apx_left_isotone)
by (simp add: mult_apx_right_isotone)
text ‹Theorem 16.2›
lemma ni_apx_isotone:
"x ⊑ y ⟹ ni(x) ⊑ ni(y)"
using apx_n_order_reverse apx_def le_supI1 n_ni ni_def ni_n_order by force
text ‹Theorem 17›
definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"
definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ n(ν f) * L"
definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu f ≡ ν f ≤ μ f ⊔ n(ν f) * top"
definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_nu f ≡ μ f ⊔ n(ν f) * L ⊑ ν f"
definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ n(ν f) * L"
definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"
lemma mu_below_l:
"μ f ≤ μ f ⊔ n(ν f) * L"
by simp
lemma l_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ n(ν f) * L ≤ ν f"
by (simp add: mu_below_nu n_L_decreasing)
lemma n_l_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ n(μ f ⊔ n(ν f) * L) = n(ν f)"
by (metis le_iff_sup mu_below_nu n_dist_sup n_n_L)
lemma l_apx_mu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ n(ν f) * L ⊑ μ f"
by (simp add: apx_def le_supI1 n_l_nu)
text ‹Theorem 17.4 implies Theorem 17.5›
lemma nu_below_mu_nu_mu_nu_apx_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu f ⟹ mu_nu_apx_nu f"
by (smt (z3) l_below_nu apx_def le_sup_iff sup.absorb2 sup_commute sup_monoid.add_assoc mu_nu_apx_nu_def n_l_nu nu_below_mu_nu_def)
text ‹Theorem 17.5 implies Theorem 17.6›
lemma mu_nu_apx_nu_mu_nu_apx_meet:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "mu_nu_apx_nu f"
shows "mu_nu_apx_meet f"
proof -
let ?l = "μ f ⊔ n(ν f) * L"
have "is_apx_meet (μ f) (ν f) ?l"
apply (unfold is_apx_meet_def, intro conjI)
apply (simp add: assms(1,2) l_apx_mu)
using assms(3) mu_nu_apx_nu_def apply blast
by (meson assms(1,2) l_below_nu apx_def order_trans sup_ge1 sup_left_isotone)
thus ?thesis
by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed
text ‹Theorem 17.6 implies Theorem 17.7›
lemma mu_nu_apx_meet_apx_meet_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto
text ‹Theorem 17.7 implies Theorem 17.4›
lemma apx_meet_below_nu_nu_below_mu_nu:
assumes "apx_meet_below_nu f"
shows "nu_below_mu_nu f"
proof -
have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ ν f ≤ μ f ⊔ n(m) * top"
by (smt (verit) sup_assoc sup_left_isotone sup_right_top apx_def mult_left_dist_sup order_trans)
thus ?thesis
by (smt (verit) assms sup_right_isotone apx_greatest_lower_bound apx_meet_below_nu_def apx_reflexive mult_left_isotone n_isotone nu_below_mu_nu_def order_trans)
qed
text ‹Theorem 17.1 implies Theorem 17.2›
lemma has_apx_least_fixpoint_kappa_apx_meet:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "apx.has_least_fixpoint f"
shows "kappa_apx_meet f"
proof -
have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
by (meson assms apx_def order.trans kappa_below_nu mu_below_kappa semiring.add_right_mono)
hence "is_apx_meet (μ f) (ν f) (κ f)"
by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
thus ?thesis
by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed
text ‹Theorem 17.2 implies Theorem 17.7›
lemma kappa_apx_meet_apx_meet_below_nu:
"has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force
text ‹Theorem 17.7 implies Theorem 17.3›
lemma apx_meet_below_nu_kappa_mu_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "isotone f"
and "apx.isotone f"
and "apx_meet_below_nu f"
shows "kappa_mu_nu f"
proof -
let ?l = "μ f ⊔ n(ν f) * L"
let ?m = "μ f △ ν f"
have 1: "?l ⊑ ν f"
using apx_meet_below_nu_nu_below_mu_nu assms(1,2,5) mu_nu_apx_nu_def nu_below_mu_nu_mu_nu_apx_nu by blast
hence 2: "?m = ?l"
using assms(1,2) mu_nu_apx_meet_def mu_nu_apx_nu_def mu_nu_apx_nu_mu_nu_apx_meet by blast
have "μ f ≤ f(?l)"
by (metis assms(1,3) isotone_def mu_unfold sup_ge1)
hence 3: "?l ≤ f(?l) ⊔ n(?l) * L"
using assms(1,2) semiring.add_right_mono n_l_nu by auto
have "f(?l) ≤ f(ν f)"
using assms(1-3) l_below_nu isotone_def by blast
also have "... ≤ ?l ⊔ n(?l) * top"
using 1 by (metis assms(2) apx_def nu_unfold)
finally have 4: "?l ⊑ f(?l)"
using 3 apx_def by blast
have 5: "f(?l) ⊑ μ f"
by (metis assms(1,2,4) apx.isotone_def is_least_fixpoint_def least_fixpoint l_apx_mu)
have "f(?l) ⊑ ν f"
using 1 by (metis assms(2,4) apx.isotone_def greatest_fixpoint is_greatest_fixpoint_def)
hence "f(?l) ⊑ ?l"
using 2 5 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
hence "f(?l) = ?l"
using 4 by (simp add: apx.order.antisym)
thus ?thesis
using 1 by (smt (verit, del_insts) assms(1,2) sup_left_isotone apx_antisymmetric apx_def apx.least_fixpoint_char greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def is_least_fixpoint_def least_fixpoint n_l_nu order_trans kappa_mu_nu_def)
qed
text ‹Theorem 17.3 implies Theorem 17.1›
lemma kappa_mu_nu_has_apx_least_fixpoint:
"kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
using kappa_mu_nu_def by auto
text ‹Theorem 17.4 implies Theorem 17.3›
lemma nu_below_mu_nu_kappa_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_mu_nu_apx_nu by blast
text ‹Theorem 17.3 implies Theorem 17.4›
lemma kappa_mu_nu_nu_below_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
by (simp add: apx_meet_below_nu_nu_below_mu_nu has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)
definition kappa_mu_nu_ni :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu_ni f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ ni(ν f)"
lemma kappa_mu_nu_ni_kappa_mu_nu:
"kappa_mu_nu_ni f ⟷ kappa_mu_nu f"
by (simp add: kappa_mu_nu_def kappa_mu_nu_ni_def ni_def)
lemma nu_below_mu_nu_kappa_mu_nu_ni:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu_ni f"
by (simp add: kappa_mu_nu_ni_kappa_mu_nu nu_below_mu_nu_kappa_mu_nu)
lemma kappa_mu_nu_ni_nu_below_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_ni f ⟹ nu_below_mu_nu f"
using kappa_mu_nu_ni_kappa_mu_nu kappa_mu_nu_nu_below_mu_nu by blast
end
class itering_apx = n_itering + semiring_apx
begin
text ‹Theorem 16.3›
lemma circ_apx_isotone:
assumes "x ⊑ y"
shows "x⇧∘ ⊑ y⇧∘"
proof -
have 1: "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "y⇧∘ ≤ x⇧∘ ⊔ x⇧∘ * n(x) * top"
by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
also have "... ≤ x⇧∘ ⊔ n(x⇧∘ * x) * top"
by (smt le_sup_iff n_isotone n_top_split order_refl order_trans right_plus_below_circ zero_right_mult_decreasing)
also have "... ≤ x⇧∘ ⊔ n(x⇧∘) * top"
by (simp add: circ_plus_same n_circ_left_unfold)
finally have 2: "y⇧∘ ≤ x⇧∘ ⊔ n(x⇧∘) * top"
.
have "x⇧∘ ≤ y⇧∘ ⊔ y⇧∘ * n(x) * L"
using 1 by (metis L_left_zero circ_isotone circ_unfold_sum mult_assoc)
also have "... = y⇧∘ ⊔ n(y⇧∘ * x) * L"
by (metis sup_assoc sup_bot_right mult_assoc mult_zero_sup_circ_2 n_L_split n_mult_right_bot)
also have "... ≤ y⇧∘ ⊔ n(x⇧∘ * x) * L ⊔ n(x⇧∘) * n(top * x) * L"
using 2 by (metis sup_assoc sup_right_isotone mult_assoc mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone)
finally have "x⇧∘ ≤ y⇧∘ ⊔ n(x⇧∘) * L"
by (metis sup_assoc circ_plus_same n_sup_left_absorb_mult n_circ_left_unfold n_dist_sup n_export ni_def ni_dist_sup)
thus ?thesis
using 2 by (simp add: apx_def)
qed
end
class omega_algebra_apx = n_omega_algebra_2 + semiring_apx
sublocale omega_algebra_apx < star: itering_apx where circ = star ..
sublocale omega_algebra_apx < nL_omega: itering_apx where circ = Omega ..
context omega_algebra_apx
begin
text ‹Theorem 16.4›
lemma omega_apx_isotone:
assumes "x ⊑ y"
shows "x⇧ω ⊑ y⇧ω"
proof -
have 1: "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "y⇧ω ≤ x⇧⋆ * n(x) * top * (x⇧⋆ * n(x) * top)⇧ω ⊔ x⇧ω ⊔ x⇧⋆ * n(x) * top * (x⇧⋆ * n(x) * top)⇧⋆ * x⇧ω"
by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
also have "... ≤ x⇧⋆ * n(x) * top ⊔ x⇧ω ⊔ x⇧⋆ * n(x) * top * (x⇧⋆ * n(x) * top)⇧⋆ * x⇧ω"
using mult_top_omega omega_unfold sup_left_isotone by auto
also have "... = x⇧⋆ * n(x) * top ⊔ x⇧ω"
by (smt (z3) mult_left_dist_sup sup_assoc sup_commute sup_left_top mult_assoc)
also have "... ≤ n(x⇧⋆ * x) * top ⊔ x⇧⋆ * bot ⊔ x⇧ω"
using n_top_split semiring.add_left_mono sup_commute by fastforce
also have "... ≤ n(x⇧⋆ * x) * top ⊔ x⇧ω"
using semiring.add_right_mono star_bot_below_omega sup_commute by fastforce
finally have 2: "y⇧ω ≤ x⇧ω ⊔ n(x⇧ω) * top"
by (metis sup_commute sup_right_isotone mult_left_isotone n_star_below_n_omega n_star_left_unfold order_trans star.circ_plus_same)
have "x⇧ω ≤ (y ⊔ n(x) * L)⇧ω"
using 1 by (simp add: omega_isotone)
also have "... = y⇧⋆ * n(x) * L * (y⇧⋆ * n(x) * L)⇧ω ⊔ y⇧ω ⊔ y⇧⋆ * n(x) * L * (y⇧⋆ * n(x) * L)⇧⋆ * y⇧ω"
by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
also have "... = y⇧⋆ * n(x) * L ⊔ y⇧ω"
using L_left_zero sup_assoc sup_monoid.add_commute mult_assoc by force
also have "... ≤ y⇧ω ⊔ y⇧⋆ * bot ⊔ n(y⇧⋆ * x) * L"
by (simp add: n_L_split sup_assoc sup_commute)
also have "... ≤ y⇧ω ⊔ n(x⇧⋆ * x) * L ⊔ n(x⇧⋆) * n(top * x) * L"
using 1 by (metis sup_right_isotone sup_bot_right apx_def mult_assoc mult_left_dist_sup mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone star.circ_apx_isotone star_mult_omega sup_assoc)
finally have "x⇧ω ≤ y⇧ω ⊔ n(x⇧ω) * L"
by (smt (verit, best) le_supE sup.orderE sup_commute sup_assoc sup_isotone mult_right_dist_sup n_sup_left_absorb_mult n_star_left_unfold ni_def ni_star_below_ni_omega order_refl order_trans star.circ_plus_same)
thus ?thesis
using 2 by (simp add: apx_def)
qed
end
class omega_algebra_apx_extra = omega_algebra_apx +
assumes n_split_omega: "x⇧ω ≤ x⇧⋆ * bot ⊔ n(x⇧ω) * top"
begin
lemma omega_n_star:
"x⇧ω ⊔ n(x⇧⋆) * top ≤ x⇧⋆ * n(x⇧ω) * top"
proof -
have 1: "n(x⇧⋆) * top ≤ n(x⇧ω) * top"
by (simp add: mult_left_isotone n_star_below_n_omega)
have "... ≤ x⇧⋆ * n(x⇧ω) * top"
by (simp add: star_n_omega_top)
thus ?thesis
using 1 by (metis le_sup_iff n_split_omega order_trans star_n_omega_top)
qed
lemma n_omega_zero:
"n(x⇧ω) = bot ⟷ n(x⇧⋆) = bot ∧ x⇧ω ≤ x⇧⋆ * bot"
by (metis sup_bot_right order.eq_iff mult_left_zero n_mult_bot n_split_omega star_bot_below_omega)
lemma n_split_nu_mu:
"y⇧ω ⊔ y⇧⋆ * z ≤ y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
proof -
have "y⇧ω ≤ y⇧⋆ * bot ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
by (smt sup_ge1 sup_right_isotone mult_left_isotone n_isotone n_split_omega order_trans)
also have "... ≤ y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
using nL_star.star_zero_below_circ_mult sup_left_isotone by auto
finally show ?thesis
by simp
qed
lemma loop_exists:
"ν (λx . y * x ⊔ z) ≤ μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * top"
by (metis n_split_nu_mu omega_loop_nu star_loop_mu)
lemma loop_apx_least_fixpoint:
"apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L)"
using apx.least_fixpoint_char affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto
lemma loop_has_apx_least_fixpoint:
"apx.has_least_fixpoint (λx . y * x ⊔ z)"
using affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto
lemma loop_semantics:
"κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L"
using apx.least_fixpoint_char loop_apx_least_fixpoint by auto
lemma loop_apx_least_fixpoint_ni:
"apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ ni(ν (λx . y * x ⊔ z)))"
using ni_def loop_apx_least_fixpoint by auto
lemma loop_semantics_ni:
"κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ ni(ν (λx . y * x ⊔ z))"
using ni_def loop_semantics by auto
text ‹Theorem 18›
lemma loop_semantics_kappa_mu_nu:
"κ (λx . y * x ⊔ z) = n(y⇧ω) * L ⊔ y⇧⋆ * z"
proof -
have "κ (λx . y * x ⊔ z) = y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * L"
by (metis loop_semantics omega_loop_nu star_loop_mu)
thus ?thesis
by (smt sup_assoc sup_commute le_iff_sup mult_right_dist_sup n_L_decreasing n_dist_sup)
qed
end
class omega_algebra_apx_extra_2 = omega_algebra_apx +
assumes omega_n_star: "x⇧ω ≤ x⇧⋆ * n(x⇧ω) * top"
begin
subclass omega_algebra_apx_extra
apply unfold_locales
using omega_n_star star_n_omega_top by auto
end
end
Theory N_Algebras
section ‹N-Algebras›
theory N_Algebras
imports Stone_Kleene_Relation_Algebras.Iterings Base Lattice_Ordered_Semirings
begin
class C_left_n_algebra = bounded_idempotent_left_semiring + bounded_distrib_lattice + n + L
begin
abbreviation C :: "'a ⇒ 'a" where "C x ≡ n(L) * top ⊓ x"
text ‹AACP Theorem 3.38›
lemma C_isotone:
"x ≤ y ⟶ C x ≤ C y"
using inf.sup_right_isotone by auto
text ‹AACP Theorem 3.40›
lemma C_decreasing:
"C x ≤ x"
by simp
end
class left_n_algebra = C_left_n_algebra +
assumes n_dist_n_add : "n(x) ⊔ n(y) = n(n(x) * top ⊔ y)"
assumes n_export : "n(x) * n(y) = n(n(x) * y)"
assumes n_left_upper_bound : "n(x) ≤ n(x ⊔ y)"
assumes n_nL_meet_L_nL0 : "n(L) * x = (x ⊓ L) ⊔ n(L * bot) * x"
assumes n_n_L_split_n_n_L_L : "x * n(y) * L = x * bot ⊔ n(x * n(y) * L) * L"
assumes n_sub_nL : "n(x) ≤ n(L)"
assumes n_L_decreasing : "n(x) * L ≤ x"
assumes n_L_T_meet_mult_combined: "C (x * y) * z ≤ C x * y * C z"
assumes n_n_top_split_n_top : "x * n(y) * top ≤ x * bot ⊔ n(x * y) * top"
assumes n_top_meet_L_below_L : "x * top * y ⊓ L ≤ x * L * y"
begin
subclass lattice_ordered_pre_left_semiring ..
lemma n_L_T_meet_mult_below:
"C (x * y) ≤ C x * y"
proof -
have "C (x * y) ≤ C x * y * C 1"
by (meson order.trans mult_sub_right_one n_L_T_meet_mult_combined)
also have "... ≤ C x * y"
by (metis mult_1_right mult_left_sub_dist_inf_right)
finally show ?thesis
.
qed
text ‹AACP Theorem 3.41›
lemma n_L_T_meet_mult_propagate:
"C x * y ≤ x * C y"
proof -
have "C x * y ≤ C x * 1 * C y"
by (metis mult_1_right mult_assoc n_L_T_meet_mult_combined mult_1_right)
also have "... ≤ x * C y"
by (simp add: mult_right_sub_dist_inf_right)
finally show ?thesis
.
qed
text ‹AACP Theorem 3.43›
lemma C_n_mult_closed:
"C (n(x) * y) = n(x) * y"
by (simp add: inf.absorb2 mult_isotone n_sub_nL)
text ‹AACP Theorem 3.40›
lemma meet_L_below_C:
"x ⊓ L ≤ C x"
by (simp add: le_supI1 n_nL_meet_L_nL0)
text ‹AACP Theorem 3.42›
lemma n_L_T_meet_mult:
"C (x * y) = C x * y"
apply (rule order.antisym)
apply (rule n_L_T_meet_mult_below)
by (smt (z3) C_n_mult_closed inf.boundedE inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_right_sub_dist_inf mult_assoc)
text ‹AACP Theorem 3.42›
lemma C_mult_propagate:
"C x * y = C x * C y"
by (smt (z3) C_n_mult_closed order.eq_iff inf.left_commute inf.sup_monoid.add_commute mult_left_sub_dist_inf_right n_L_T_meet_mult_propagate)
text ‹AACP Theorem 3.32›
lemma meet_L_below_n_L:
"x ⊓ L ≤ n(L) * x"
by (simp add: n_nL_meet_L_nL0)
text ‹AACP Theorem 3.27›
lemma n_vector_meet_L:
"x * top ⊓ L ≤ x * L"
by (metis mult_1_right n_top_meet_L_below_L)
lemma n_right_upper_bound:
"n(x) ≤ n(y ⊔ x)"
by (simp add: n_left_upper_bound sup_commute)
text ‹AACP Theorem 3.1›
lemma n_isotone:
"x ≤ y ⟹ n(x) ≤ n(y)"
by (metis le_iff_sup n_left_upper_bound)
lemma n_add_left_zero:
"n(bot) ⊔ n(x) = n(x)"
using le_iff_sup sup_bot_right sup_right_divisibility n_isotone by auto
text ‹AACP Theorem 3.13›
lemma n_mult_right_zero_L:
"n(x) * bot ≤ L"
by (meson bot_least mult_isotone n_L_decreasing n_sub_nL order_trans)
lemma n_add_left_top:
"n(top) ⊔ n(x) = n(top)"
by (simp add: sup_absorb1 n_isotone)
text ‹AACP Theorem 3.18›
lemma n_n_L:
"n(n(x) * L) = n(x)"
by (metis order.antisym n_dist_n_add n_export n_sub_nL sup_bot_right sup_commute sup_top_left n_add_left_zero n_right_upper_bound)
lemma n_mult_transitive:
"n(x) * n(x) ≤ n(x)"
by (metis mult_right_isotone n_export n_sub_nL n_n_L)
lemma n_mult_left_absorb_add_sub:
"n(x) * (n(x) ⊔ n(y)) ≤ n(x)"
by (metis mult_right_isotone n_dist_n_add n_export n_sub_nL n_n_L)
text ‹AACP Theorem 3.21›
lemma n_mult_left_lower_bound:
"n(x) * n(y) ≤ n(x)"
by (metis mult_right_isotone n_export n_sub_nL n_n_L)
text ‹AACP Theorem 3.20›
lemma n_mult_left_zero:
"n(bot) * n(x) = n(bot)"
by (metis n_export sup_absorb1 n_add_left_zero n_mult_left_lower_bound)
lemma n_mult_right_one:
"n(x) * n(top) = n(x)"
using n_dist_n_add n_export sup_commute n_add_left_zero by fastforce
lemma n_L_increasing:
"n(x) ≤ n(n(x) * L)"
by (simp add: n_n_L)
text ‹AACP Theorem 3.2›
lemma n_galois:
"n(x) ≤ n(y) ⟷ n(x) * L ≤ y"
by (metis mult_left_isotone n_L_decreasing n_L_increasing n_isotone order_trans)
lemma n_add_n_top:
"n(x ⊔ n(x) * top) = n(x)"
by (metis n_dist_n_add sup.idem sup_commute)
text ‹AACP Theorem 3.6›
lemma n_L_below_nL_top:
"L ≤ n(L) * top"
by (metis inf_top.left_neutral meet_L_below_n_L)
text ‹AACP Theorem 3.4›
lemma n_less_eq_char_n:
"x ≤ y ⟷ x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
proof
assume "x ≤ y"
thus "x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
by (simp add: inf.coboundedI2 le_supI1)
next
assume 1: "x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
hence "x ≤ y ⊔ (x ⊓ L)"
using sup_commute sup_inf_distrib2 by force
also have "... ≤ y ⊔ C x"
using sup_right_isotone meet_L_below_C by blast
also have "... ≤ y ⊔ n(y) * top"
using 1 by simp
finally have "x ≤ y ⊔ (L ⊓ n(y) * top)"
using 1 by (simp add: sup_inf_distrib1)
thus "x ≤ y"
by (metis inf_commute n_L_decreasing order_trans sup_absorb1 n_vector_meet_L)
qed
text ‹AACP Theorem 3.31›
lemma n_L_decreasing_meet_L:
"n(x) * L ≤ x ⊓ L"
using n_sub_nL n_galois by auto
text ‹AACP Theorem 3.5›
lemma n_zero_L_zero:
"n(bot) * L = bot"
by (simp add: le_bot n_L_decreasing)
lemma n_L_top_below_L:
"L * top ≤ L"
proof -
have "n(L * bot) * L * top ≤ L * bot"
by (metis dense_top_closed mult_isotone n_L_decreasing zero_vector mult_assoc)
hence "n(L * bot) * L * top ≤ L"
using order_lesseq_imp zero_right_mult_decreasing by blast
hence "n(L) * L * top ≤ L"
by (metis inf.absorb2 n_nL_meet_L_nL0 order.refl sup.absorb_iff1 top_right_mult_increasing mult_assoc)
thus "L * top ≤ L"
by (metis inf.absorb2 inf.sup_monoid.add_commute n_L_decreasing n_L_below_nL_top n_vector_meet_L)
qed
text ‹AACP Theorem 3.9›
lemma n_L_top_L:
"L * top = L"
by (simp add: order.antisym top_right_mult_increasing n_L_top_below_L)
text ‹AACP Theorem 3.10›
lemma n_L_below_L:
"L * x ≤ L"
by (metis mult_right_isotone top.extremum n_L_top_L)
text ‹AACP Theorem 3.7›
lemma n_nL_nT:
"n(L) = n(top)"
using order.eq_iff n_sub_nL n_add_left_top by auto
text ‹AACP Theorem 3.8›
lemma n_L_L:
"n(L) * L = L"
using order.antisym meet_L_below_n_L n_L_decreasing_meet_L by fastforce
lemma n_top_L:
"n(top) * L = L"
using n_L_L n_nL_nT by auto
text ‹AACP Theorem 3.23›
lemma n_n_L_split_n_L:
"x * n(y) * L ≤ x * bot ⊔ n(x * y) * L"
by (metis n_n_L_split_n_n_L_L n_L_decreasing mult_assoc mult_left_isotone mult_right_isotone n_isotone sup_right_isotone)
text ‹AACP Theorem 3.12›
lemma n_L_split_n_L_L:
"x * L = x * bot ⊔ n(x * L) * L"
apply (rule order.antisym)
apply (metis mult_assoc n_n_L_split_n_L n_L_L)
by (simp add: mult_right_isotone n_L_decreasing)
text ‹AACP Theorem 3.11›
lemma n_L_split_L:
"x * L ≤ x * bot ⊔ L"
by (metis n_n_L_split_n_n_L_L n_sub_nL sup_right_isotone mult_assoc n_L_L n_galois)
text ‹AACP Theorem 3.24›
lemma n_split_top:
"x * n(y) * top ≤ x * y ⊔ n(x * y) * top"
proof -
have "x * bot ⊔ n(x * y) * top ≤ x * y ⊔ n(x * y) * top"
by (meson bot_least mult_isotone order.refl sup_left_isotone)
thus ?thesis
using order.trans n_n_top_split_n_top by blast
qed
text ‹AACP Theorem 3.9›
lemma n_L_L_L:
"L * L = L"
by (metis inf.sup_monoid.add_commute inf_absorb1 n_L_below_L n_L_top_L n_vector_meet_L)
text ‹AACP Theorem 3.9›
lemma n_L_top_L_L:
"L * top * L = L"
by (simp add: n_L_L_L n_L_top_L)
text ‹AACP Theorem 3.19›
lemma n_n_nL:
"n(x) = n(x) * n(L)"
by (simp add: n_export n_n_L)
lemma n_L_mult_idempotent:
"n(L) * n(L) = n(L)"
using n_n_nL by auto
text ‹AACP Theorem 3.22›
lemma n_n_L_n:
"n(x * n(y) * L) ≤ n(x * y)"
by (simp add: mult_right_isotone n_L_decreasing mult_assoc n_isotone)
text ‹AACP Theorem 3.3›
lemma n_less_eq_char:
"x ≤ y ⟷ x ≤ y ⊔ L ∧ x ≤ y ⊔ n(y) * top"
by (meson inf.coboundedI2 le_supI1 n_less_eq_char_n)
text ‹AACP Theorem 3.28›
lemma n_top_meet_L_split_L:
"x * top * y ⊓ L ≤ x * bot ⊔ L * y"
proof -
have "x * top * y ⊓ L ≤ x * bot ⊔ n(x * L) * L * y"
by (smt n_top_meet_L_below_L mult_assoc n_L_L_L n_L_split_n_L_L mult_right_dist_sup mult_left_zero)
also have "... ≤ x * bot ⊔ x * L * y"
using mult_left_isotone n_L_decreasing sup_right_isotone by force
also have "... ≤ x * bot ⊔ (x * bot ⊔ L) * y"
using mult_left_isotone sup_right_isotone n_L_split_L by blast
also have "... = x * bot ⊔ x * bot * y ⊔ L * y"
by (simp add: mult_right_dist_sup sup_assoc)
also have "... = x * bot ⊔ L * y"
by (simp add: mult_assoc)
finally show ?thesis
.
qed
text ‹AACP Theorem 3.29›
lemma n_top_meet_L_L_meet_L:
"x * top * y ⊓ L = x * L * y ⊓ L"
apply (rule order.antisym)
apply (simp add: n_top_meet_L_below_L)
by (metis inf.sup_monoid.add_commute inf.sup_right_isotone mult_isotone order.refl top.extremum)
lemma n_n_top_below_n_L:
"n(x * top) ≤ n(x * L)"
by (meson order.trans n_L_decreasing_meet_L n_galois n_vector_meet_L)
text ‹AACP Theorem 3.14›
lemma n_n_top_n_L:
"n(x * top) = n(x * L)"
by (metis order.antisym mult_right_isotone n_isotone n_n_top_below_n_L top_greatest)
text ‹AACP Theorem 3.30›
lemma n_meet_L_0_below_0_meet_L:
"(x ⊓ L) * bot ≤ x * bot ⊓ L"
by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)
text ‹AACP Theorem 3.15›
lemma n_n_L_below_L:
"n(x) * L ≤ x * L"
by (metis mult_assoc mult_left_isotone n_L_L_L n_L_decreasing)
lemma n_n_L_below_n_L_L:
"n(x) * L ≤ n(x * L) * L"
by (simp add: mult_left_isotone n_galois n_n_L_below_L)
text ‹AACP Theorem 3.16›
lemma n_below_n_L:
"n(x) ≤ n(x * L)"
by (simp add: n_galois n_n_L_below_L)
text ‹AACP Theorem 3.17›
lemma n_below_n_L_mult:
"n(x) ≤ n(L) * n(x)"
by (metis n_export order_trans meet_L_below_n_L n_L_decreasing_meet_L n_isotone n_n_L)
text ‹AACP Theorem 3.33›
lemma n_meet_L_below:
"n(x) ⊓ L ≤ x"
by (meson inf.coboundedI1 inf.coboundedI2 le_supI2 sup.cobounded1 top_right_mult_increasing n_less_eq_char)
text ‹AACP Theorem 3.35›
lemma n_meet_L_top_below_n_L:
"(n(x) ⊓ L) * top ≤ n(x) * L"
proof -
have "(n(x) ⊓ L) * top ≤ n(x) * top ⊓ L * top"
by (meson mult_right_sub_dist_inf)
thus ?thesis
by (metis n_L_top_L n_vector_meet_L order_trans)
qed
text ‹AACP Theorem 3.34›
lemma n_meet_L_top_below:
"(n(x) ⊓ L) * top ≤ x"
using order.trans n_L_decreasing n_meet_L_top_below_n_L by blast
text ‹AACP Theorem 3.36›
lemma n_n_meet_L:
"n(x) = n(x ⊓ L)"
by (meson order.antisym inf.cobounded1 n_L_decreasing_meet_L n_galois n_isotone)
lemma n_T_below_n_meet:
"n(x) * top = n(C x) * top"
by (metis inf.absorb2 inf.sup_monoid.add_assoc meet_L_below_C n_n_meet_L)
text ‹AACP Theorem 3.44›
lemma n_C:
"n(C x) = n(x)"
by (metis n_T_below_n_meet n_export n_mult_right_one)
text ‹AACP Theorem 3.37›
lemma n_T_meet_L:
"n(x) * top ⊓ L = n(x) * L"
by (metis antisym_conv n_L_decreasing_meet_L n_n_L n_n_top_n_L n_vector_meet_L)
text ‹AACP Theorem 3.39›
lemma n_L_top_meet_L:
"C L = L"
by (simp add: n_L_L n_T_meet_L)
end
class n_algebra = left_n_algebra + idempotent_left_zero_semiring
begin
text ‹AACP Theorem 3.25›
lemma n_top_split_0:
"n(x) * top * y ≤ x * y ⊔ n(x * bot) * top"
proof -
have 1: "n(x) * top * y ⊓ L ≤ x * y"
using inf.coboundedI1 mult_left_isotone n_L_decreasing_meet_L n_top_meet_L_L_meet_L by force
have "n(x) * top * y = n(x) * n(L) * top * y"
using n_n_nL by auto
also have "... = n(x) * ((top * y ⊓ L) ⊔ n(L * bot) * top * y)"
by (metis mult_assoc n_nL_meet_L_nL0)
also have "... ≤ n(x) * (top * y ⊓ L) ⊔ n(x) * n(L * bot) * top"
by (metis sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone top_greatest)
also have "... ≤ (n(x) * top * y ⊓ L) ⊔ n(n(x) * L * bot) * top"
by (smt sup_left_isotone order.trans inf_greatest mult_assoc mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right n_export n_galois n_sub_nL)
also have "... ≤ x * y ⊔ n(n(x) * L * bot) * top"
using 1 sup_left_isotone by blast
also have "... ≤ x * y ⊔ n(x * bot) * top"
using mult_left_isotone n_galois n_isotone order.refl sup_right_isotone by auto
finally show ?thesis
.
qed
text ‹AACP Theorem 3.26›
lemma n_top_split:
"n(x) * top * y ≤ x * y ⊔ n(x * y) * top"
by (metis order.trans sup_bot_right mult_assoc sup_right_isotone mult_left_isotone mult_left_sub_dist_sup_right n_isotone n_top_split_0)
end
end
Theory Recursion
section ‹Recursion›
theory Recursion
imports Approximation N_Algebras
begin
class n_algebra_apx = n_algebra + apx +
assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
begin
lemma apx_transitive_2:
assumes "x ⊑ y"
and "y ⊑ z"
shows "x ⊑ z"
proof -
have "C z ≤ C (y ⊔ n(y) * top)"
using assms(2) apx_def le_inf_iff by blast
also have "... = C y ⊔ n(y) * top"
by (simp add: C_n_mult_closed inf_sup_distrib1)
also have "... ≤ x ⊔ n(x) * top ⊔ n(y) * top"
using assms(1) apx_def sup_left_isotone by blast
also have "... = x ⊔ n(x) * top ⊔ n(C y) * top"
by (simp add: n_C)
also have "... ≤ x ⊔ n(x) * top"
by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
finally show ?thesis
by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed
lemma apx_meet_L:
assumes "y ⊑ x"
shows "x ⊓ L ≤ y ⊓ L"
proof -
have "x ⊓ L = C x ⊓ L"
by (simp add: inf.left_commute inf.sup_monoid.add_assoc n_L_top_meet_L)
also have "... ≤ (y ⊔ n(y) * top) ⊓ L"
using assms apx_def inf.sup_left_isotone by blast
also have "... = (y ⊓ L) ⊔ (n(y) * top ⊓ L)"
by (simp add: inf_sup_distrib2)
also have "... ≤ (y ⊓ L) ⊔ n(y ⊓ L) * top"
using n_n_meet_L sup_right_isotone by force
finally show ?thesis
by (metis le_iff_sup inf_le2 n_less_eq_char)
qed
text ‹AACP Theorem 4.1›
subclass apx_biorder
apply unfold_locales
apply (simp add: apx_def inf.coboundedI2)
apply (metis sup_same_context order.antisym apx_def apx_meet_L relative_equality)
using apx_transitive_2 by blast
lemma sup_apx_left_isotone_2:
assumes "x ⊑ y"
shows "x ⊔ z ⊑ y ⊔ z"
proof -
have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
have "C (y ⊔ z) ≤ x ⊔ n(x) * top ⊔ C z"
using assms apx_def inf_sup_distrib1 sup_left_isotone by auto
also have "... ≤ x ⊔ z ⊔ n(x) * top"
using inf.coboundedI1 inf.sup_monoid.add_commute sup.cobounded1 sup.cobounded2 sup_assoc sup_least sup_right_isotone by auto
also have "... ≤ x ⊔ z ⊔ n(x ⊔ z) * top"
using mult_isotone n_left_upper_bound semiring.add_left_mono by force
finally show ?thesis
using 1 apx_def by blast
qed
lemma mult_apx_left_isotone_2:
assumes "x ⊑ y"
shows "x * z ⊑ y * z"
proof -
have "x * z ≤ y * z ⊔ L * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
hence 1: "x * z ≤ y * z ⊔ L"
using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
have "C (y * z) = C y * z"
by (simp add: n_L_T_meet_mult)
also have "... ≤ x * z ⊔ n(x) * top * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
also have "... ≤ x * z ⊔ n(x * z) * top"
by (simp add: n_top_split)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
lemma mult_apx_right_isotone_2:
assumes "x ⊑ y"
shows "z * x ⊑ z * y"
proof -
have "z * x ≤ z * y ⊔ z * L"
by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
also have "... ≤ z * y ⊔ z * bot ⊔ L"
using n_L_split_L semiring.add_left_mono sup_assoc by presburger
finally have 1: "z * x ≤ z * y ⊔ L"
using mult_right_isotone sup.absorb_iff1 by auto
have "C (z * y) ≤ z * C y"
by (simp add: n_L_T_meet_mult n_L_T_meet_mult_propagate)
also have "... ≤ z * (x ⊔ n(x) * top)"
using assms apx_def mult_right_isotone by blast
also have "... = z * x ⊔ z * n(x) * top"
by (simp add: mult_left_dist_sup mult_assoc)
also have "... ≤ z * x ⊔ n(z * x) * top"
by (simp add: n_split_top)
finally show ?thesis
using 1 apx_def by blast
qed
text ‹AACP Theorem 4.1 and Theorem 4.2›
subclass apx_semiring
apply unfold_locales
apply (simp add: apx_def n_L_below_nL_top sup.absorb2)
using sup_apx_left_isotone_2 apply blast
using mult_apx_left_isotone_2 apply blast
by (simp add: mult_apx_right_isotone_2)
text ‹AACP Theorem 4.2›
lemma meet_L_apx_isotone:
"x ⊑ y ⟹ x ⊓ L ⊑ y ⊓ L"
by (smt (verit) apx_meet_L apx_def inf.cobounded2 inf.left_commute n_L_top_meet_L n_less_eq_char sup.absorb2)
text ‹AACP Theorem 4.2›
lemma n_L_apx_isotone:
assumes "x ⊑ y"
shows "n(x) * L ⊑ n(y) * L"
proof -
have "C (n(y) * L) ≤ n(C y) * L"
by (simp add: n_C)
also have "... ≤ n(x) * L ⊔ n(n(x) * L) * top"
by (metis assms apx_def n_add_n_top n_galois n_isotone n_n_L)
finally show ?thesis
using apx_def le_inf_iff n_L_decreasing_meet_L sup.absorb2 by auto
qed
definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"
definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ (ν f ⊓ L)"
definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu f ≡ C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"
definition nu_below_mu_nu_2 :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu_2 f ≡ C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_nu f ≡ μ f ⊔ (ν f ⊓ L) ⊑ ν f"
definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ (ν f ⊓ L)"
definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"
lemma mu_below_l:
"μ f ≤ μ f ⊔ (ν f ⊓ L)"
by simp
lemma l_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ (ν f ⊓ L) ≤ ν f"
by (simp add: mu_below_nu)
lemma n_l_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (μ f ⊔ (ν f ⊓ L)) ⊓ L = ν f ⊓ L"
by (meson l_below_nu inf.cobounded1 inf.sup_same_context order_trans sup_ge2)
lemma l_apx_mu:
"μ f ⊔ (ν f ⊓ L) ⊑ μ f"
proof -
have 1: "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ L"
using sup_right_isotone by auto
have "C (μ f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
by (simp add: le_supI1)
thus ?thesis
using 1 apx_def by blast
qed
text ‹AACP Theorem 4.8 implies Theorem 4.9›
lemma nu_below_mu_nu_nu_below_mu_nu_2:
assumes "nu_below_mu_nu f"
shows "nu_below_mu_nu_2 f"
proof -
have "C (ν f) = C (C (ν f))"
by auto
also have "... ≤ C (μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top)"
using assms nu_below_mu_nu_def by auto
also have "... = C (μ f ⊔ (ν f ⊓ L)) ⊔ C (n(ν f) * top)"
using inf_sup_distrib1 by auto
also have "... = C (μ f ⊔ (ν f ⊓ L)) ⊔ n(ν f) * top"
by (simp add: C_n_mult_closed)
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"
using inf_le2 sup_left_isotone by blast
also have "... = μ f ⊔ (ν f ⊓ L) ⊔ n(ν f ⊓ L) * top"
using n_n_meet_L by auto
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
using mult_isotone n_right_upper_bound semiring.add_left_mono by auto
finally show ?thesis
by (simp add: nu_below_mu_nu_2_def)
qed
text ‹AACP Theorem 4.9 implies Theorem 4.8›
lemma nu_below_mu_nu_2_nu_below_mu_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "nu_below_mu_nu_2 f"
shows "nu_below_mu_nu f"
proof -
have "C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
using assms(3) nu_below_mu_nu_2_def by blast
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"
by (metis assms(1,2) order.eq_iff n_n_meet_L n_l_nu)
finally show ?thesis
using nu_below_mu_nu_def by blast
qed
lemma nu_below_mu_nu_equivalent:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (nu_below_mu_nu f ⟷ nu_below_mu_nu_2 f)"
using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast
text ‹AACP Theorem 4.9 implies Theorem 4.10›
lemma nu_below_mu_nu_2_mu_nu_apx_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "nu_below_mu_nu_2 f"
shows "mu_nu_apx_nu f"
proof -
have "μ f ⊔ (ν f ⊓ L) ≤ ν f ⊔ L"
using assms(1,2) l_below_nu le_supI1 by blast
thus ?thesis
using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed
text ‹AACP Theorem 4.10 implies Theorem 4.11›
lemma mu_nu_apx_nu_mu_nu_apx_meet:
assumes "mu_nu_apx_nu f"
shows "mu_nu_apx_meet f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "is_apx_meet (μ f) (ν f) ?l"
proof (unfold is_apx_meet_def, intro conjI)
show "?l ⊑ μ f"
by (simp add: l_apx_mu)
show "?l ⊑ ν f"
using assms mu_nu_apx_nu_def by blast
show "∀w. w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ ?l"
by (metis apx_meet_L le_inf_iff sup.absorb1 sup_apx_left_isotone)
qed
thus ?thesis
by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed
text ‹AACP Theorem 4.11 implies Theorem 4.12›
lemma mu_nu_apx_meet_apx_meet_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto
text ‹AACP Theorem 4.12 implies Theorem 4.9›
lemma apx_meet_below_nu_nu_below_mu_nu_2:
assumes "apx_meet_below_nu f"
shows "nu_below_mu_nu_2 f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ C (ν f) ≤ ?l ⊔ n(?l) * top"
proof
fix m
show "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ C (ν f) ≤ ?l ⊔ n(?l) * top"
proof
assume 1: "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f"
hence "m ≤ ?l"
by (smt (z3) apx_def sup.left_commute sup_inf_distrib1 sup_left_divisibility)
hence "m ⊔ n(m) * top ≤ ?l ⊔ n(?l) * top"
by (metis sup_mono mult_left_isotone n_isotone)
thus "C (ν f) ≤ ?l ⊔ n(?l) * top"
using 1 apx_def order.trans by blast
qed
qed
thus ?thesis
by (smt (verit, ccfv_threshold) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed
text ‹AACP Theorem 4.5 implies Theorem 4.6›
lemma has_apx_least_fixpoint_kappa_apx_meet:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "apx.has_least_fixpoint f"
shows "kappa_apx_meet f"
proof -
have 1: "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ C (κ f) ≤ w ⊔ n(w) * top"
by (metis assms(2,3) apx_def inf.sup_right_isotone order_trans kappa_below_nu)
have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ≤ κ f ⊔ L"
by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
hence "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
using 1 apx_def by blast
hence "is_apx_meet (μ f) (ν f) (κ f)"
by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
thus ?thesis
by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed
text ‹AACP Theorem 4.6 implies Theorem 4.12›
lemma kappa_apx_meet_apx_meet_below_nu:
"has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force
text ‹AACP Theorem 4.12 implies Theorem 4.7›
lemma apx_meet_below_nu_kappa_mu_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "isotone f"
and "apx.isotone f"
and "apx_meet_below_nu f"
shows "kappa_mu_nu f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
let ?m = "μ f △ ν f"
have 1: "?m = ?l"
by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
have 2: "?l ≤ f(?l) ⊔ L"
proof -
have "?l ≤ μ f ⊔ L"
using sup_right_isotone by auto
also have "... = f(μ f) ⊔ L"
by (simp add: assms(1) mu_unfold)
also have "... ≤ f(?l) ⊔ L"
using assms(3) isotone_def sup_ge1 sup_left_isotone by blast
finally show "?l ≤ f(?l) ⊔ L"
.
qed
have "C (f(?l)) ≤ ?l ⊔ n(?l) * top"
proof -
have "C (f(?l)) ≤ C (f(ν f))"
using assms(1-3) l_below_nu inf.sup_right_isotone isotone_def by blast
also have "... = C (ν f)"
by (metis assms(2) nu_unfold)
also have "... ≤ ?l ⊔ n(?l) * top"
by (metis assms(5) apx_meet_below_nu_nu_below_mu_nu_2 nu_below_mu_nu_2_def)
finally show "C (f(?l)) ≤ ?l ⊔ n(?l) * top"
.
qed
hence 3: "?l ⊑ f(?l)"
using 2 apx_def by blast
have 4: "f(?l) ⊑ μ f"
proof -
have "?l ⊑ μ f"
by (simp add: l_apx_mu)
thus "f(?l) ⊑ μ f"
by (metis assms(1,4) mu_unfold ord.isotone_def)
qed
have "f(?l) ⊑ ν f"
proof -
have "?l ⊑ ν f"
using 1
by (metis apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def)
thus "f(?l) ⊑ ν f"
by (metis assms(2,4) nu_unfold ord.isotone_def)
qed
hence "f(?l) ⊑ ?l"
using 1 4 apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def by fastforce
hence 5: "f(?l) = ?l"
using 3 apx.order.antisym by blast
have "∀y . f(y) = y ⟶ ?l ⊑ y"
proof
fix y
show "f(y) = y ⟶ ?l ⊑ y"
proof
assume 6: "f(y) = y"
hence 7: "?l ≤ y ⊔ L"
using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
have "y ≤ ν f"
using 6 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
hence "C y ≤ ?l ⊔ n(?l) * top"
using assms(5) apx_meet_below_nu_nu_below_mu_nu_2 inf.sup_right_isotone nu_below_mu_nu_2_def order_trans by blast
thus "?l ⊑ y"
using 7 apx_def by blast
qed
qed
thus ?thesis
using 5 apx.least_fixpoint_same apx.has_least_fixpoint_def apx.is_least_fixpoint_def kappa_mu_nu_def by auto
qed
text ‹AACP Theorem 4.7 implies Theorem 4.5›
lemma kappa_mu_nu_has_apx_least_fixpoint:
"kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
by (simp add: kappa_mu_nu_def)
text ‹AACP Theorem 4.8 implies Theorem 4.7›
lemma nu_below_mu_nu_kappa_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast
text ‹AACP Theorem 4.7 implies Theorem 4.8›
lemma kappa_mu_nu_nu_below_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_has_apx_least_fixpoint nu_below_mu_nu_2_nu_below_mu_nu)
definition kappa_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu_L f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ n(ν f) * L"
definition nu_below_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu_L f ≡ C (ν f) ≤ μ f ⊔ n(ν f) * top"
definition mu_nu_apx_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_nu_L f ≡ μ f ⊔ n(ν f) * L ⊑ ν f"
definition mu_nu_apx_meet_L :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_meet_L f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ n(ν f) * L"
lemma n_below_l:
"x ⊔ n(y) * L ≤ x ⊔ (y ⊓ L)"
using n_L_decreasing_meet_L semiring.add_left_mono by auto
lemma n_equal_l:
assumes "nu_below_mu_nu_L f"
shows "μ f ⊔ n(ν f) * L = μ f ⊔ (ν f ⊓ L)"
proof -
have "ν f ⊓ L ≤ (μ f ⊔ n(ν f) * top) ⊓ L"
by (meson assms order.trans inf.boundedI inf.cobounded2 meet_L_below_C nu_below_mu_nu_L_def)
also have "... ≤ μ f ⊔ (n(ν f) * top ⊓ L)"
by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute inf_sup_distrib1)
also have "... ≤ μ f ⊔ n(ν f) * L"
by (simp add: n_T_meet_L)
finally have "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ n(ν f) * L"
by simp
thus "μ f ⊔ n(ν f) * L = μ f ⊔ (ν f ⊓ L)"
by (meson order.antisym n_below_l)
qed
text ‹AACP Theorem 4.14 implies Theorem 4.8›
lemma nu_below_mu_nu_L_nu_below_mu_nu:
"nu_below_mu_nu_L f ⟹ nu_below_mu_nu f"
by (metis sup_assoc sup_right_top mult_left_dist_sup n_equal_l nu_below_mu_nu_L_def nu_below_mu_nu_def)
text ‹AACP Theorem 4.14 implies Theorem 4.13›
lemma nu_below_mu_nu_L_kappa_mu_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu_L f ⟹ kappa_mu_nu_L f"
using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by force
text ‹AACP Theorem 4.14 implies Theorem 4.15›
lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto
text ‹AACP Theorem 4.14 implies Theorem 4.16›
lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_meet_L f"
using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto
text ‹AACP Theorem 4.15 implies Theorem 4.14›
lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "mu_nu_apx_nu_L f"
shows "nu_below_mu_nu_L f"
proof -
let ?n = "μ f ⊔ n(ν f) * L"
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "C (ν f) ≤ ?n ⊔ n(?n) * top"
using assms(3) apx_def mu_nu_apx_nu_L_def by blast
also have "... ≤ ?n ⊔ n(?l) * top"
using mult_left_isotone n_L_decreasing_meet_L n_isotone semiring.add_left_mono by auto
also have "... ≤ ?n ⊔ n(ν f) * top"
using assms(1,2) l_below_nu mult_left_isotone n_isotone sup_right_isotone by auto
finally show ?thesis
by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed
text ‹AACP Theorem 4.13 implies Theorem 4.15›
lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
"has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by fastforce
text ‹AACP Theorem 4.16 implies Theorem 4.15›
lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
"mu_nu_apx_meet_L f ⟹ mu_nu_apx_nu_L f"
using apx_meet_char is_apx_meet_def mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce
text ‹AACP Theorem 4.13 implies Theorem 4.14›
lemma kappa_mu_nu_L_nu_below_mu_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ nu_below_mu_nu_L f"
by (simp add: kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L)
lemma unfold_fold_1:
"isotone f ⟹ has_least_prefixpoint f ⟹ apx.has_least_fixpoint f ⟹ f(x) ≤ x ⟹ κ f ≤ x ⊔ L"
by (metis sup_left_isotone apx_def has_least_fixpoint_def is_least_prefixpoint_def least_prefixpoint_char least_prefixpoint_fixpoint order_trans pmu_mu kappa_apx_below_mu)
lemma unfold_fold_2:
assumes "isotone f"
and "apx.isotone f"
and "has_least_prefixpoint f"
and "has_greatest_fixpoint f"
and "apx.has_least_fixpoint f"
and "f(x) ≤ x"
and "κ f ⊓ L ≤ x ⊓ L"
shows "κ f ≤ x"
proof -
have "κ f ⊓ L = ν f ⊓ L"
by (smt (z3) apx_meet_L assms(4,5) order.eq_iff inf.cobounded1 kappa_apx_below_nu kappa_below_nu le_inf_iff)
hence "κ f = (κ f ⊓ L) ⊔ μ f"
by (metis assms(1-5) apx_meet_below_nu_kappa_mu_nu has_apx_least_fixpoint_kappa_apx_meet sup_commute least_fixpoint_char least_prefixpoint_fixpoint kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)
thus ?thesis
by (metis assms(1,3,6,7) sup_least is_least_prefixpoint_def least_prefixpoint le_inf_iff pmu_mu)
qed
end
class n_algebra_apx_2 = n_algebra + apx +
assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ y ≤ x ⊔ n(x) * top"
begin
lemma apx_transitive_2:
assumes "x ⊑ y"
and "y ⊑ z"
shows "x ⊑ z"
proof -
have "z ≤ y ⊔ n(y) * top"
using assms(2) apx_def by auto
also have "... ≤ x ⊔ n(x) * top ⊔ n(y) * top"
using assms(1) apx_def sup_left_isotone by blast
also have "... ≤ x ⊔ n(x) * top"
by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
finally show ?thesis
by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed
lemma apx_meet_L:
assumes "y ⊑ x"
shows "x ⊓ L ≤ y ⊓ L"
proof -
have "x ⊓ L ≤ (y ⊓ L) ⊔ (n(y) * top ⊓ L)"
by (metis assms apx_def inf.sup_left_isotone inf_sup_distrib2)
also have "... ≤ (y ⊓ L) ⊔ n(y ⊓ L) * top"
using n_n_meet_L sup_right_isotone by force
finally show ?thesis
by (metis le_iff_sup inf_le2 n_less_eq_char)
qed
text ‹AACP Theorem 4.1›
subclass apx_biorder
apply unfold_locales
apply (simp add: apx_def)
using apx_def order.eq_iff n_less_eq_char apply blast
using apx_transitive_2 by blast
lemma sup_apx_left_isotone_2:
assumes "x ⊑ y"
shows "x ⊔ z ⊑ y ⊔ z"
proof -
have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
have "y ⊔ z ≤ x ⊔ n(x) * top ⊔ z"
using assms apx_def sup_left_isotone by blast
also have "... ≤ x ⊔ z ⊔ n(x ⊔ z) * top"
by (metis sup_assoc sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound)
finally show ?thesis
using 1 apx_def by auto
qed
lemma mult_apx_left_isotone_2:
assumes "x ⊑ y"
shows "x * z ⊑ y * z"
proof -
have "x * z ≤ y * z ⊔ L * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
hence 1: "x * z ≤ y * z ⊔ L"
using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
have "y * z ≤ x * z ⊔ n(x) * top * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
also have "... ≤ x * z ⊔ n(x * z) * top"
by (simp add: n_top_split)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
lemma mult_apx_right_isotone_2:
assumes "x ⊑ y"
shows "z * x ⊑ z * y"
proof -
have "z * x ≤ z * y ⊔ z * L"
by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
also have "... ≤ z * y ⊔ z * bot ⊔ L"
using n_L_split_L semiring.add_left_mono sup_assoc by auto
finally have 1: "z * x ≤ z * y ⊔ L"
using mult_right_isotone sup.absorb_iff1 by force
have "z * y ≤ z * (x ⊔ n(x) * top)"
using assms apx_def mult_right_isotone by blast
also have "... = z * x ⊔ z * n(x) * top"
by (simp add: mult_left_dist_sup mult_assoc)
also have "... ≤ z * x ⊔ n(z * x) * top"
by (simp add: n_split_top)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
end
end
Theory N_Omega_Algebras
section ‹N-Omega-Algebras›
theory N_Omega_Algebras
imports Omega_Algebras Recursion
begin
class itering_apx = bounded_itering + n_algebra_apx
begin
lemma circ_L:
"L⇧∘ = L ⊔ 1"
by (metis sup_commute mult_top_circ n_L_top_L)
lemma C_circ_import:
"C (x⇧∘) ≤ (C x)⇧∘"
proof -
have 1: "C x * x⇧∘ ≤ (C x)⇧∘ * C x"
using C_mult_propagate circ_simulate order.eq_iff by blast
have "C (x⇧∘) = C (1 ⊔ x * x⇧∘)"
by (simp add: circ_left_unfold)
also have "... = C 1 ⊔ C (x * x⇧∘)"
by (simp add: inf_sup_distrib1)
also have "... ≤ 1 ⊔ C (x * x⇧∘)"
using sup_left_isotone by auto
also have "... = 1 ⊔ C x * x⇧∘"
by (simp add: n_L_T_meet_mult)
also have "... ≤ (C x)⇧∘"
using 1 by (meson circ_reflexive order.trans le_supI right_plus_below_circ)
finally show ?thesis
.
qed
text ‹AACP Theorem 4.3 and Theorem 4.4›
lemma circ_apx_isotone:
assumes "x ⊑ y"
shows "x⇧∘ ⊑ y⇧∘"
proof -
have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
have "C (y⇧∘) ≤ (C y)⇧∘"
by (simp add: C_circ_import)
also have "... ≤ x⇧∘ ⊔ x⇧∘ * n(x) * top"
using 1 by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
also have "... ≤ x⇧∘ ⊔ (x⇧∘ * bot ⊔ n(x⇧∘ * x) * top)"
using n_n_top_split_n_top sup_right_isotone by blast
also have "... ≤ x⇧∘ ⊔ (x⇧∘ * bot ⊔ n(x⇧∘) * top)"
using circ_plus_same left_plus_below_circ mult_left_isotone n_isotone sup_right_isotone by auto
also have "... = x⇧∘ ⊔ n(x⇧∘) * top"
by (meson sup.left_idem sup_relative_same_increasing zero_right_mult_decreasing)
finally have 2: "C (y⇧∘) ≤ x⇧∘ ⊔ n(x⇧∘) * top"
.
have "x⇧∘ ≤ y⇧∘ * L⇧∘"
using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone n_L_below_L le_iff_sup mult_assoc)
also have "... = y⇧∘ ⊔ y⇧∘ * L"
using circ_L mult_left_dist_sup sup_commute by auto
also have "... ≤ y⇧∘ ⊔ y⇧∘ * bot ⊔ L"
using n_L_split_L semiring.add_left_mono sup_assoc by auto
finally have "x⇧∘ ≤ y⇧∘ ⊔ L"
using sup.absorb1 zero_right_mult_decreasing by force
thus "x⇧∘ ⊑ y⇧∘"
using 2 by (simp add: apx_def)
qed
end
class n_omega_algebra_1 = bounded_left_zero_omega_algebra + n_algebra_apx + Omega +
assumes Omega_def: "x⇧Ω = n(x⇧ω) * L ⊔ x⇧⋆"
begin
text ‹AACP Theorem 8.13›
lemma C_omega_export:
"C (x⇧ω) = (C x)⇧ω"
proof -
have "C (x⇧ω) = C x * C (x⇧ω)"
by (metis C_mult_propagate n_L_T_meet_mult omega_unfold)
hence 1: "C (x⇧ω) ≤ (C x)⇧ω"
using eq_refl omega_induct_mult by auto
have "(C x)⇧ω = C (x * (C x)⇧ω)"
using n_L_T_meet_mult omega_unfold by auto
also have "... ≤ C (x⇧ω)"
by (metis calculation C_decreasing inf_le1 le_infI omega_induct_mult)
finally show ?thesis
using 1 order.antisym by blast
qed
text ‹AACP Theorem 8.2›
lemma L_mult_star:
"L * x⇧⋆ = L"
by (metis n_L_top_L star.circ_left_top mult_assoc)
text ‹AACP Theorem 8.3›
lemma mult_L_star:
"(x * L)⇧⋆ = 1 ⊔ x * L"
by (metis L_mult_star star.circ_mult_1 mult_assoc)
lemma mult_L_omega_below:
"(x * L)⇧ω ≤ x * L"
by (metis mult_right_isotone n_L_below_L omega_slide)
text ‹AACP Theorem 8.5›
lemma mult_L_sup_star:
"(x * L ⊔ y)⇧⋆ = y⇧⋆ ⊔ y⇧⋆ * x * L"
using L_mult_star mult_1_right mult_left_dist_sup star_sup_1 sup_commute mult_L_star mult_assoc by auto
lemma mult_L_sup_omega_below:
"(x * L ⊔ y)⇧ω ≤ y⇧ω ⊔ y⇧⋆ * x * L"
proof -
have "(x * L ⊔ y)⇧ω ≤ y⇧⋆ * x * L ⊔ (y⇧⋆ * x * L)⇧⋆ * y⇧ω"
by (metis sup_commute mult_assoc omega_decompose sup_left_isotone mult_L_omega_below)
also have "... ≤ y⇧ω ⊔ y⇧⋆ * x * L"
by (smt (z3) le_iff_sup le_supI mult_left_dist_sup n_L_below_L star_left_induct sup.cobounded2 sup.left_idem sup.orderE sup_assoc sup_commute mult_assoc)
finally show ?thesis
.
qed
lemma n_Omega_isotone:
"x ≤ y ⟹ x⇧Ω ≤ y⇧Ω"
by (metis Omega_def sup_mono mult_left_isotone n_isotone omega_isotone star_isotone)
lemma n_star_below_Omega:
"x⇧⋆ ≤ x⇧Ω"
by (simp add: Omega_def)
lemma mult_L_star_mult_below:
"(x * L)⇧⋆ * y ≤ y ⊔ x * L"
by (metis sup_right_isotone mult_assoc mult_right_isotone n_L_below_L star_left_induct)
end
sublocale n_omega_algebra_1 < star: itering_apx where circ = star ..
class n_omega_algebra = n_omega_algebra_1 + n_algebra_apx +
assumes n_split_omega_mult: "C (x⇧ω) ≤ x⇧⋆ * n(x⇧ω) * top"
assumes tarski: "x * L ≤ x * L * x * L"
begin
text ‹AACP Theorem 8.4›
lemma mult_L_omega:
"(x * L)⇧ω = x * L"
apply (rule order.antisym)
apply (rule mult_L_omega_below)
using omega_induct_mult tarski mult_assoc by auto
text ‹AACP Theorem 8.6›
lemma mult_L_sup_omega:
"(x * L ⊔ y)⇧ω = y⇧ω ⊔ y⇧⋆ * x * L"
apply (rule order.antisym)
apply (rule mult_L_sup_omega_below)
by (metis le_supI omega_isotone omega_sub_dist_2 sup.cobounded2 sup_commute mult_L_omega mult_assoc)
text ‹AACP Theorem 8.1›
lemma tarski_mult_top_idempotent:
"x * L = x * L * x * L"
by (metis omega_unfold mult_L_omega mult_assoc)
text ‹AACP Theorem 8.7›
lemma n_below_n_omega:
"n(x) ≤ n(x⇧ω)"
proof -
have "n(x) * L ≤ n(x) * L * n(x) * L"
by (simp add: tarski)
also have "... ≤ x * n(x) * L"
by (simp add: mult_isotone n_L_decreasing)
finally have "n(x) * L ≤ x⇧ω"
by (simp add: omega_induct_mult mult_assoc)
thus ?thesis
by (simp add: n_galois)
qed
text ‹AACP Theorem 8.14›
lemma n_split_omega_sup_zero:
"C (x⇧ω) ≤ x⇧⋆ * bot ⊔ n(x⇧ω) * top"
proof -
have "n(x⇧ω) * top ⊔ x * (x⇧⋆ * bot ⊔ n(x⇧ω) * top) = n(x⇧ω) * top ⊔ x * x⇧⋆ * bot ⊔ x * n(x⇧ω) * top"
by (simp add: mult_left_dist_sup sup_assoc mult_assoc)
also have "... ≤ n(x⇧ω) * top ⊔ x * x⇧⋆ * bot ⊔ x * bot ⊔ n(x⇧ω) * top"
by (metis sup_assoc sup_right_isotone n_n_top_split_n_top omega_unfold)
also have "... = x * x⇧⋆ * bot ⊔ n(x⇧ω) * top"
by (smt sup_assoc sup_commute sup_left_top sup_bot_right mult_assoc mult_left_dist_sup)
also have "... ≤ x⇧⋆ * bot ⊔ n(x⇧ω) * top"
by (metis sup_left_isotone mult_left_isotone star.left_plus_below_circ)
finally have "x⇧⋆ * n(x⇧ω) * top ≤ x⇧⋆ * bot ⊔ n(x⇧ω) * top"
using star_left_induct mult_assoc by auto
thus ?thesis
using n_split_omega_mult order_trans by blast
qed
lemma n_split_omega_sup:
"C (x⇧ω) ≤ x⇧⋆ ⊔ n(x⇧ω) * top"
by (metis sup_left_isotone n_split_omega_sup_zero order_trans zero_right_mult_decreasing)
text ‹AACP Theorem 8.12›
lemma n_dist_omega_star:
"n(y⇧ω ⊔ y⇧⋆ * z) = n(y⇧ω) ⊔ n(y⇧⋆ * z)"
proof -
have "n(y⇧ω ⊔ y⇧⋆ * z) = n(C (y⇧ω) ⊔ C (y⇧⋆ * z))"
by (metis inf_sup_distrib1 n_C)
also have "... ≤ n(C (y⇧ω) ⊔ y⇧⋆ * z)"
using n_isotone semiring.add_right_mono sup_commute by auto
also have "... ≤ n(y⇧⋆ * bot ⊔ n(y⇧ω) * top ⊔ y⇧⋆ * z)"
using n_isotone semiring.add_right_mono n_split_omega_sup_zero by blast
also have "... = n(y⇧ω) ⊔ n(y⇧⋆ * z)"
by (smt sup_assoc sup_commute sup_bot_right mult_left_dist_sup n_dist_n_add)
finally show ?thesis
by (simp add: order.antisym n_isotone)
qed
lemma mult_L_sup_circ_below:
"(x * L ⊔ y)⇧Ω ≤ n(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
proof -
have "(x * L ⊔ y)⇧Ω ≤ n(y⇧ω ⊔ y⇧⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧⋆"
by (simp add: Omega_def mult_L_sup_omega)
also have "... = n(y⇧ω) * L ⊔ n(y⇧⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧⋆"
by (simp add: semiring.distrib_right mult_assoc n_dist_omega_star)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
by (smt (z3) le_supI sup.cobounded1 sup_assoc sup_commute sup_idem sup_right_isotone mult_L_sup_star n_L_decreasing)
finally show ?thesis
.
qed
lemma n_mult_omega_L_below_zero:
"n(y * x⇧ω) * L ≤ y * x⇧⋆ * bot ⊔ y * n(x⇧ω) * L"
proof -
have "n(y * x⇧ω) * L ≤ C (y * x⇧ω) ⊓ L"
by (metis n_C n_L_decreasing_meet_L)
also have "... ≤ y * C (x⇧ω) ⊓ L"
using inf.sup_left_isotone n_L_T_meet_mult n_L_T_meet_mult_propagate by auto
also have "... ≤ y * (x⇧⋆ * bot ⊔ n(x⇧ω) * top) ⊓ L"
using inf.sup_left_isotone mult_right_isotone n_split_omega_sup_zero by auto
also have "... = (y * x⇧⋆ * bot ⊓ L) ⊔ (y * n(x⇧ω) * top ⊓ L)"
using inf_sup_distrib2 mult_left_dist_sup mult_assoc by auto
also have "... ≤ (y * x⇧⋆ * bot ⊓ L) ⊔ y * n(x⇧ω) * L"
using n_vector_meet_L sup_right_isotone by auto
also have "... ≤ y * x⇧⋆ * bot ⊔ y * n(x⇧ω) * L"
using sup_left_isotone by auto
finally show ?thesis
.
qed
text ‹AACP Theorem 8.10›
lemma n_mult_omega_L_star_zero:
"y * x⇧⋆ * bot ⊔ n(y * x⇧ω) * L = y * x⇧⋆ * bot ⊔ y * n(x⇧ω) * L"
apply (rule order.antisym)
apply (simp add: n_mult_omega_L_below_zero)
by (smt sup_assoc sup_commute sup_bot_left sup_right_isotone mult_assoc mult_left_dist_sup n_n_L_split_n_L)
text ‹AACP Theorem 8.11›
lemma n_mult_omega_L_star:
"y * x⇧⋆ ⊔ n(y * x⇧ω) * L = y * x⇧⋆ ⊔ y * n(x⇧ω) * L"
by (metis zero_right_mult_decreasing n_mult_omega_L_star_zero sup_relative_same_increasing)
lemma n_mult_omega_L_below:
"n(y * x⇧ω) * L ≤ y * x⇧⋆ ⊔ y * n(x⇧ω) * L"
using sup_right_divisibility n_mult_omega_L_star by blast
lemma n_omega_L_below_zero:
"n(x⇧ω) * L ≤ x * x⇧⋆ * bot ⊔ x * n(x⇧ω) * L"
by (metis omega_unfold n_mult_omega_L_below_zero)
lemma n_omega_L_below:
"n(x⇧ω) * L ≤ x⇧⋆ ⊔ x * n(x⇧ω) * L"
by (metis omega_unfold n_mult_omega_L_below sup_left_isotone star.left_plus_below_circ order_trans)
lemma n_omega_L_star_zero:
"x * x⇧⋆ * bot ⊔ n(x⇧ω) * L = x * x⇧⋆ * bot ⊔ x * n(x⇧ω) * L"
by (metis n_mult_omega_L_star_zero omega_unfold)
text ‹AACP Theorem 8.8›
lemma n_omega_L_star:
"x⇧⋆ ⊔ n(x⇧ω) * L = x⇧⋆ ⊔ x * n(x⇧ω) * L"
by (metis star.circ_mult_upper_bound star.left_plus_below_circ bot_least n_omega_L_star_zero sup_relative_same_increasing)
text ‹AACP Theorem 8.9›
lemma n_omega_L_star_zero_star:
"x⇧⋆ * bot ⊔ n(x⇧ω) * L = x⇧⋆ * bot ⊔ x⇧⋆ * n(x⇧ω) * L"
by (metis n_mult_omega_L_star_zero star_mult_omega mult_assoc star.circ_transitive_equal)
text ‹AACP Theorem 8.8›
lemma n_omega_L_star_star:
"x⇧⋆ ⊔ n(x⇧ω) * L = x⇧⋆ ⊔ x⇧⋆ * n(x⇧ω) * L"
by (metis zero_right_mult_decreasing n_omega_L_star_zero_star sup_relative_same_increasing)
lemma n_Omega_left_unfold:
"1 ⊔ x * x⇧Ω = x⇧Ω"
by (smt Omega_def sup_assoc sup_commute mult_assoc mult_left_dist_sup n_omega_L_star star.circ_left_unfold)
lemma n_Omega_left_slide:
"(x * y)⇧Ω * x ≤ x * (y * x)⇧Ω"
proof -
have "(x * y)⇧Ω * x ≤ x * y * n((x * y)⇧ω) * L ⊔ (x * y)⇧⋆ * x"
by (smt Omega_def sup_commute sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L n_omega_L_star)
also have "... ≤ x * (y * bot ⊔ n(y * (x * y)⇧ω) * L) ⊔ (x * y)⇧⋆ * x"
by (metis mult_right_isotone n_n_L_split_n_L sup_commute sup_right_isotone mult_assoc)
also have "... = x * (y * x)⇧Ω"
by (smt (verit, del_insts) le_supI1 star_slide Omega_def sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_dist_sup omega_slide star.circ_increasing star.circ_slide bot_least)
finally show ?thesis
.
qed
lemma n_Omega_sup_1:
"(x ⊔ y)⇧Ω = x⇧Ω * (y * x⇧Ω)⇧Ω"
proof -
have 1: "(x ⊔ y)⇧Ω = n((x⇧⋆ * y)⇧ω) * L ⊔ n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * x⇧⋆"
by (simp add: Omega_def omega_decompose semiring.distrib_right star.circ_sup_9 n_dist_omega_star)
have "n((x⇧⋆ * y)⇧ω) * L ≤ (x⇧⋆ * y)⇧⋆ ⊔ x⇧⋆ * (y * n((x⇧⋆ * y)⇧ω) * L)"
by (metis n_omega_L_below mult_assoc)
also have "... ≤ (x⇧⋆ * y)⇧⋆ ⊔ x⇧⋆ * y * bot ⊔ x⇧⋆ * n((y * x⇧⋆)⇧ω) * L"
by (smt sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone n_n_L_split_n_L omega_slide)
also have "... = (x⇧⋆ * y)⇧⋆ ⊔ x⇧⋆ * n((y * x⇧⋆)⇧ω) * L"
by (metis sup_commute le_iff_sup star.circ_sub_dist_1 zero_right_mult_decreasing)
also have "... ≤ x⇧⋆ * (y * x⇧⋆)⇧⋆ ⊔ x⇧⋆ * n((y * x⇧⋆)⇧ω) * L"
by (metis star_outer_increasing star_slide star_star_absorb sup_left_isotone)
also have "... ≤ x⇧⋆ * (y * x⇧Ω)⇧Ω"
by (metis Omega_def sup_commute mult_assoc mult_left_dist_sup mult_right_isotone n_Omega_isotone n_star_below_Omega)
also have "... ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
by (simp add: mult_left_isotone n_star_below_Omega)
finally have 2: "n((x⇧⋆ * y)⇧ω) * L ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
.
have "n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ≤ n(x⇧ω) * L ⊔ x⇧⋆ * (y * x⇧⋆)⇧⋆ ⊔ x⇧⋆ * (y * x⇧⋆)⇧⋆ * y * n(x⇧ω) * L"
by (smt sup_assoc sup_commute mult_left_one mult_right_dist_sup n_mult_omega_L_below star.circ_mult star.circ_slide)
also have "... = n(x⇧ω) * L * (y * x⇧Ω)⇧⋆ ⊔ x⇧⋆ * (y * x⇧Ω)⇧⋆"
by (smt Omega_def sup_assoc mult_L_sup_star mult_assoc mult_left_dist_sup L_mult_star)
also have "... ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
by (simp add: Omega_def mult_isotone)
finally have 3: "n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
.
have "(x⇧⋆ * y)⇧⋆ * x⇧⋆ ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
by (metis star_slide mult_isotone mult_right_isotone n_star_below_Omega order_trans star_isotone)
hence 4: "(x ⊔ y)⇧Ω ≤ x⇧Ω * (y * x⇧Ω)⇧Ω"
using 1 2 3 by simp
have 5: "x⇧Ω * (y * x⇧Ω)⇧Ω ≤ n(x⇧ω) * L ⊔ x⇧⋆ * n((y * x⇧Ω)⇧ω) * L ⊔ x⇧⋆ * (y * x⇧Ω)⇧⋆"
by (smt Omega_def sup_assoc sup_left_isotone mult_assoc mult_left_dist_sup mult_right_dist_sup mult_right_isotone n_L_below_L)
have "n(x⇧ω) * L ≤ n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L"
by (metis sup_commute sup_ge1 mult_left_isotone n_isotone star.circ_loop_fixpoint)
hence 6: "n(x⇧ω) * L ≤ (x ⊔ y)⇧Ω"
using 1 order_lesseq_imp by fastforce
have "x⇧⋆ * n((y * x⇧Ω)⇧ω) * L ≤ x⇧⋆ * n((y * x⇧⋆)⇧ω ⊔ (y * x⇧⋆)⇧⋆ * y * n(x⇧ω) * L) * L"
by (metis Omega_def mult_L_sup_omega_below mult_assoc mult_left_dist_sup mult_left_isotone mult_right_isotone n_isotone)
also have "... ≤ x⇧⋆ * bot ⊔ n(x⇧⋆ * ((y * x⇧⋆)⇧ω ⊔ (y * x⇧⋆)⇧⋆ * y * n(x⇧ω) * L)) * L"
by (simp add: n_n_L_split_n_L)
also have "... ≤ x⇧⋆ ⊔ n((x⇧⋆ * y)⇧ω ⊔ x⇧⋆ * (y * x⇧⋆)⇧⋆ * y * n(x⇧ω) * L) * L"
using omega_slide semiring.distrib_left sup_mono zero_right_mult_decreasing mult_assoc by fastforce
also have "... ≤ x⇧⋆ ⊔ n((x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L) * L"
by (smt sup_right_divisibility sup_right_isotone mult_left_isotone n_isotone star.circ_mult)
also have "... ≤ x⇧⋆ ⊔ n((x ⊔ y)⇧ω) * L"
by (metis sup_right_isotone mult_assoc mult_left_isotone mult_right_isotone n_L_decreasing n_isotone omega_decompose)
also have "... ≤ (x ⊔ y)⇧Ω"
by (simp add: Omega_def le_supI1 star_isotone sup_commute)
finally have 7: "x⇧⋆ * n((y * x⇧Ω)⇧ω) * L ≤ (x ⊔ y)⇧Ω"
.
have "x⇧⋆ * (y * x⇧Ω)⇧⋆ ≤ (x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L"
by (smt Omega_def sup_right_isotone mult_L_sup_star mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ star_slide)
also have "... ≤ (x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L"
by (simp add: n_mult_omega_L_star)
also have "... ≤ (x ⊔ y)⇧Ω"
by (smt Omega_def sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound omega_decompose star.circ_sup)
finally have "n(x⇧ω) * L ⊔ x⇧⋆ * n((y * x⇧Ω)⇧ω) * L ⊔ x⇧⋆ * (y * x⇧Ω)⇧⋆ ≤ (x ⊔ y)⇧Ω"
using 6 7 by simp
hence "x⇧Ω * (y * x⇧Ω)⇧Ω ≤ (x ⊔ y)⇧Ω"
using 5 order.trans by blast
thus ?thesis
using 4 order.antisym by blast
qed
end
sublocale n_omega_algebra < nL_omega: left_zero_conway_semiring where circ = Omega
apply unfold_locales
apply (simp add: n_Omega_left_unfold)
apply (simp add: n_Omega_left_slide)
by (simp add: n_Omega_sup_1)
context n_omega_algebra
begin
text ‹AACP Theorem 8.16›
lemma omega_apx_isotone:
assumes "x ⊑ y"
shows "x⇧ω ⊑ y⇧ω"
proof -
have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
have "n(x) * top ⊔ x * (x⇧ω ⊔ n(x⇧ω) * top) ≤ n(x) * top ⊔ x⇧ω ⊔ n(x⇧ω) * top"
by (metis le_supI n_split_top sup.cobounded1 sup_assoc mult_assoc mult_left_dist_sup sup_right_isotone omega_unfold)
also have "... ≤ x⇧ω ⊔ n(x⇧ω) * top"
by (metis sup_commute sup_right_isotone mult_left_isotone n_below_n_omega sup_assoc sup_idem)
finally have 2: "x⇧⋆ * n(x) * top ≤ x⇧ω ⊔ n(x⇧ω) * top"
using star_left_induct mult_assoc by auto
have "C (y⇧ω) = (C y)⇧ω"
by (simp add: C_omega_export)
also have "... ≤ (x ⊔ n(x) * top)⇧ω"
using 1 omega_isotone by blast
also have "... = (x⇧⋆ * n(x) * top)⇧ω ⊔ (x⇧⋆ * n(x) * top)⇧⋆ * x⇧ω"
by (simp add: omega_decompose mult_assoc)
also have "... ≤ x⇧⋆ * n(x) * top ⊔ (x⇧⋆ * n(x) * top)⇧⋆ * x⇧ω"
using mult_top_omega sup_left_isotone by blast
also have "... = x⇧⋆ * n(x) * top ⊔ (1 ⊔ x⇧⋆ * n(x) * top * (x⇧⋆ * n(x) * top)⇧⋆) * x⇧ω"
by (simp add: star_left_unfold_equal)
also have "... ≤ x⇧ω ⊔ x⇧⋆ * n(x) * top"
by (smt sup_mono sup_least mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest sup.cobounded2)
also have "... ≤ x⇧ω ⊔ n(x⇧ω) * top"
using 2 by simp
finally have 3: "C (y⇧ω) ≤ x⇧ω ⊔ n(x⇧ω) * top"
.
have "x⇧ω ≤ (y ⊔ L)⇧ω"
using 1 omega_isotone by simp
also have "... = (y⇧⋆ * L)⇧ω ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
by (simp add: omega_decompose)
also have "... = y⇧⋆ * L * (y⇧⋆ * L)⇧ω ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
using omega_unfold by auto
also have "... ≤ y⇧⋆ * L ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
by (metis sup_left_isotone n_L_below_L mult_assoc mult_right_isotone)
also have "... = y⇧⋆ * L ⊔ (1 ⊔ y⇧⋆ * L * (y⇧⋆ * L)⇧⋆) * y⇧ω"
by (simp add: star_left_unfold_equal)
also have "... ≤ y⇧⋆ * L ⊔ y⇧ω"
by (simp add: mult_L_star_mult_below star_left_unfold_equal sup_commute)
also have "... ≤ y⇧⋆ * bot ⊔ L ⊔ y⇧ω"
using n_L_split_L sup_left_isotone by auto
finally have "x⇧ω ≤ y⇧ω ⊔ L"
by (simp add: star_bot_below_omega sup.absorb1 sup.left_commute sup_commute)
thus "x⇧ω ⊑ y⇧ω"
using 3 by (simp add: apx_def)
qed
lemma combined_apx_left_isotone:
"x ⊑ y ⟹ n(x⇧ω) * L ⊔ x⇧⋆ * z ⊑ n(y⇧ω) * L ⊔ y⇧⋆ * z"
by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)
lemma combined_apx_left_isotone_2:
"x ⊑ y ⟹ (x⇧ω ⊓ L) ⊔ x⇧⋆ * z ⊑ (y⇧ω ⊓ L) ⊔ y⇧⋆ * z"
by (metis sup_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)
lemma combined_apx_right_isotone:
"y ⊑ z ⟹ n(x⇧ω) * L ⊔ x⇧⋆ * y ⊑ n(x⇧ω) * L ⊔ x⇧⋆ * z"
by (simp add: mult_apx_isotone sup_apx_left_isotone sup_commute)
lemma combined_apx_right_isotone_2:
"y ⊑ z ⟹ (x⇧ω ⊓ L) ⊔ x⇧⋆ * y ⊑ (x⇧ω ⊓ L) ⊔ x⇧⋆ * z"
by (simp add: mult_apx_right_isotone sup_apx_right_isotone)
lemma combined_apx_isotone:
"x ⊑ y ⟹ w ⊑ z ⟹ n(x⇧ω) * L ⊔ x⇧⋆ * w ⊑ n(y⇧ω) * L ⊔ y⇧⋆ * z"
by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)
lemma combined_apx_isotone_2:
"x ⊑ y ⟹ w ⊑ z ⟹ (x⇧ω ⊓ L) ⊔ x⇧⋆ * w ⊑ (y⇧ω ⊓ L) ⊔ y⇧⋆ * z"
by (meson combined_apx_left_isotone_2 combined_apx_right_isotone_2 apx.order.trans)
lemma n_split_nu_mu:
"C (y⇧ω ⊔ y⇧⋆ * z) ≤ y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
proof -
have "C (y⇧ω ⊔ y⇧⋆ * z) ≤ C (y⇧ω) ⊔ y⇧⋆ * z"
by (simp add: inf_sup_distrib1 le_supI1 sup_commute)
also have "... ≤ y⇧⋆ * bot ⊔ n(y⇧ω) * top ⊔ y⇧⋆ * z"
using n_split_omega_sup_zero sup_left_isotone by blast
also have "... ≤ y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound sup_right_isotone by force
finally show ?thesis
.
qed
lemma n_split_nu_mu_2:
"C (y⇧ω ⊔ y⇧⋆ * z) ≤ y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L) ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
proof -
have "C (y⇧ω ⊔ y⇧⋆ * z) ≤ C (y⇧ω) ⊔ y⇧⋆ * z"
using inf.sup_left_isotone sup_inf_distrib2 by auto
also have "... ≤ y⇧⋆ * bot ⊔ n(y⇧ω) * top ⊔ y⇧⋆ * z"
using n_split_omega_sup_zero sup_left_isotone by blast
also have "... ≤ y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * top"
using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound semiring.add_left_mono by auto
finally show ?thesis
using order_lesseq_imp semiring.add_right_mono sup.cobounded1 by blast
qed
lemma loop_exists:
"C (ν (λx . y * x ⊔ z)) ≤ μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * top"
using omega_loop_nu star_loop_mu n_split_nu_mu by auto
lemma loop_exists_2:
"C (ν (λx . y * x ⊔ z)) ≤ μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L) ⊔ n(ν (λx . y * x ⊔ z)) * top"
by (simp add: omega_loop_nu star_loop_mu n_split_nu_mu_2)
lemma loop_apx_least_fixpoint:
"apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L)"
proof -
have "kappa_mu_nu_L (λx . y * x ⊔ z)"
by (metis affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_L_def nu_below_mu_nu_L_kappa_mu_nu_L)
thus ?thesis
using apx.least_fixpoint_char kappa_mu_nu_L_def by force
qed
lemma loop_apx_least_fixpoint_2:
"apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L))"
proof -
have "kappa_mu_nu (λx . y * x ⊔ z)"
by (metis affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone loop_exists_2 nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu)
thus ?thesis
using apx.least_fixpoint_char kappa_mu_nu_def by force
qed
lemma loop_has_apx_least_fixpoint:
"apx.has_least_fixpoint (λx . y * x ⊔ z)"
using apx.least_fixpoint_char loop_apx_least_fixpoint by blast
lemma loop_semantics:
"κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L"
using apx.least_fixpoint_char loop_apx_least_fixpoint by force
lemma loop_semantics_2:
"κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L)"
using apx.least_fixpoint_char loop_apx_least_fixpoint_2 by force
text ‹AACP Theorem 8.15›
lemma loop_semantics_kappa_mu_nu:
"κ (λx . y * x ⊔ z) = n(y⇧ω) * L ⊔ y⇧⋆ * z"
proof -
have "κ (λx . y * x ⊔ z) = y⇧⋆ * z ⊔ n(y⇧ω ⊔ y⇧⋆ * z) * L"
using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint by auto
thus ?thesis
by (smt n_dist_omega_star sup_assoc mult_right_dist_sup sup_commute le_iff_sup n_L_decreasing)
qed
text ‹AACP Theorem 8.15›
lemma loop_semantics_kappa_mu_nu_2:
"κ (λx . y * x ⊔ z) = (y⇧ω ⊓ L) ⊔ y⇧⋆ * z"
proof -
have "κ (λx . y * x ⊔ z) = y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L)"
using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint_2 by auto
thus ?thesis
by (metis sup_absorb2 sup_ge2 sup_inf_distrib1 sup_monoid.add_commute)
qed
text ‹AACP Theorem 8.16›
lemma loop_semantics_apx_left_isotone:
"w ⊑ y ⟹ κ (λx . w * x ⊔ z) ⊑ κ (λx . y * x ⊔ z)"
by (metis loop_semantics_kappa_mu_nu_2 combined_apx_left_isotone_2)
text ‹AACP Theorem 8.16›
lemma loop_semantics_apx_right_isotone:
"w ⊑ z ⟹ κ (λx . y * x ⊔ w) ⊑ κ (λx . y * x ⊔ z)"
by (metis loop_semantics_kappa_mu_nu_2 combined_apx_right_isotone_2)
lemma loop_semantics_apx_isotone:
"v ⊑ y ⟹ w ⊑ z ⟹ κ (λx . v * x ⊔ w) ⊑ κ (λx . y * x ⊔ z)"
using apx_transitive_2 loop_semantics_apx_left_isotone loop_semantics_apx_right_isotone by blast
end
end
Theory N_Omega_Binary_Iterings
section ‹N-Omega Binary Iterings›
theory N_Omega_Binary_Iterings
imports N_Omega_Algebras Binary_Iterings_Strict
begin
sublocale extended_binary_itering < left_zero_conway_semiring where circ = "(λx . x ⋆ 1)"
apply unfold_locales
using while_left_unfold apply force
apply (metis mult_1_right while_one_mult_below while_slide)
by (simp add: while_one_while while_sumstar_2)
class binary_itering_apx = bounded_binary_itering + n_algebra_apx
begin
lemma C_while_import:
"C (x ⋆ z) = C (C x ⋆ z)"
proof -
have 1: "C x * (x ⋆ z) ≤ C x ⋆ (C x * z)"
using C_mult_propagate while_simulate by force
have "C (x ⋆ z) = C z ⊔ C x * (x ⋆ z)"
by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
also have "... ≤ C x ⋆ z"
using 1 by (metis C_decreasing sup_mono while_right_unfold)
finally have "C (x ⋆ z) ≤ C (C x ⋆ z)"
by simp
thus ?thesis
by (metis order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute while_absorb_2 while_increasing)
qed
lemma C_while_preserve:
"C (x ⋆ z) = C (x ⋆ C z)"
proof -
have "C x * (x ⋆ z) ≤ C x ⋆ (C x * z)"
using C_mult_propagate while_simulate by auto
also have "... ≤ x ⋆ (x * C z)"
using C_decreasing n_L_T_meet_mult_propagate while_isotone by blast
finally have 1: "C x * (x ⋆ z) ≤ x ⋆ (x * C z)"
.
have "C (x ⋆ z) = C z ⊔ C x * (x ⋆ z)"
by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
also have "... ≤ x ⋆ C z"
using 1 by (meson order.trans le_supI while_increasing while_right_plus_below)
finally have "C (x ⋆ z) ≤ C (x ⋆ C z)"
by simp
thus ?thesis
by (meson order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.eq_refl while_isotone)
qed
lemma C_while_import_preserve:
"C (x ⋆ z) = C (C x ⋆ C z)"
using C_while_import C_while_preserve by auto
lemma while_L_L:
"L ⋆ L = L"
by (metis n_L_top_L while_mult_star_exchange while_right_top)
lemma while_L_below_sup:
"L ⋆ x ≤ x ⊔ L"
by (metis while_left_unfold sup_right_isotone n_L_below_L)
lemma while_L_split:
"x ⋆ L ≤ (x ⋆ y) ⊔ L"
proof -
have "x ⋆ L ≤ (x ⋆ bot) ⊔ L"
by (metis sup_commute sup_bot_left mult_1_right n_L_split_L while_right_unfold while_simulate_left_plus while_zero)
thus ?thesis
by (metis sup_commute sup_right_isotone order_trans while_right_isotone bot_least)
qed
lemma while_n_while_top_split:
"x ⋆ (n(x ⋆ y) * top) ≤ (x ⋆ bot) ⊔ n(x ⋆ y) * top"
proof -
have "x * n(x ⋆ y) * top ≤ x * bot ⊔ n(x * (x ⋆ y)) * top"
by (simp add: n_n_top_split_n_top)
also have "... ≤ n(x ⋆ y) * top ⊔ x * bot"
by (metis sup_commute sup_right_isotone mult_left_isotone n_isotone while_left_plus_below)
finally have "x ⋆ (n(x ⋆ y) * top) ≤ n(x ⋆ y) * top ⊔ (x ⋆ (x * bot))"
by (metis mult_assoc mult_1_right while_simulate_left mult_left_zero while_left_top)
also have "... ≤ (x ⋆ bot) ⊔ n(x ⋆ y) * top"
using sup_left_isotone while_right_plus_below by auto
finally show ?thesis
.
qed
lemma circ_apx_right_isotone:
assumes "x ⊑ y"
shows "z ⋆ x ⊑ z ⋆ y"
proof -
have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "z ⋆ x ≤ (z ⋆ y) ⊔ (z ⋆ L)"
by (metis while_left_dist_sup while_right_isotone)
hence 2: "z ⋆ x ≤ (z ⋆ y) ⊔ L"
by (meson le_supI order_lesseq_imp sup.cobounded1 while_L_split)
have "z ⋆ (n(z ⋆ x) * top) ≤ (z ⋆ bot) ⊔ n(z ⋆ x) * top"
by (simp add: while_n_while_top_split)
also have "... ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
using sup_left_isotone while_right_isotone by force
finally have 3: "z ⋆ (n(x) * top) ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
by (metis mult_left_isotone n_isotone order_trans while_increasing while_right_isotone)
have "C (z ⋆ y) ≤ z ⋆ C y"
by (metis C_while_preserve inf.cobounded2)
also have "... ≤ (z ⋆ x) ⊔ (z ⋆ (n(x) * top))"
using 1 by (metis while_left_dist_sup while_right_isotone)
also have "... ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
using 3 by simp
finally show ?thesis
using 2 apx_def by auto
qed
end
class extended_binary_itering_apx = binary_itering_apx + bounded_extended_binary_itering +
assumes n_below_while_zero: "n(x) ≤ n(x ⋆ bot)"
begin
lemma circ_apx_right_isotone:
assumes "x ⊑ y"
shows "x ⋆ z ⊑ y ⋆ z"
proof -
have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
using assms apx_def by auto
hence "x ⋆ z ≤ ((y ⋆ 1) * L) ⋆ (y ⋆ z)"
by (metis while_left_isotone while_sumstar_3)
also have "... ≤ (y ⋆ z) ⊔ (y ⋆ 1) * L"
by (metis while_productstar sup_right_isotone mult_right_isotone n_L_below_L while_slide)
also have "... ≤ (y ⋆ z) ⊔ L"
by (meson order.trans le_supI sup.cobounded1 while_L_split while_one_mult_below)
finally have 2: "x ⋆ z ≤ (y ⋆ z) ⊔ L"
.
have "C (y ⋆ z) ≤ C y ⋆ z"
by (metis C_while_import inf.sup_right_divisibility)
also have "... ≤ ((x ⋆ 1) * n(x) * top) ⋆ (x ⋆ z)"
using 1 by (metis while_left_isotone mult_assoc while_sumstar_3)
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ 1) * n(x) * top"
by (metis while_productstar sup_left_top sup_right_isotone mult_assoc mult_left_sub_dist_sup_right while_slide)
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (n(x) * top))"
using sup_right_isotone while_one_mult_below mult_assoc by auto
also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (n(x ⋆ z) * top))"
by (metis n_below_while_zero bot_least while_right_isotone n_isotone mult_left_isotone sup_right_isotone order_trans)
also have "... ≤ (x ⋆ z) ⊔ n(x ⋆ z) * top"
by (metis sup_assoc sup_right_isotone while_n_while_top_split sup_bot_right while_left_dist_sup)
finally show ?thesis
using 2 apx_def by auto
qed
end
class n_omega_algebra_binary = n_omega_algebra + while +
assumes while_def: "x ⋆ y = n(x⇧ω) * L ⊔ x⇧⋆ * y"
begin
lemma while_omega_inf_L_star:
"x ⋆ y = (x⇧ω ⊓ L) ⊔ x⇧⋆ * y"
by (metis loop_semantics_kappa_mu_nu loop_semantics_kappa_mu_nu_2 while_def)
lemma while_one_mult_while_below_1:
"(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ v"
proof -
have "(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ (y ⋆ v)"
by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def mult_left_one)
also have "... = n(y⇧ω) * L ⊔ y⇧⋆ * n(y⇧ω) * L ⊔ y⇧⋆ * y⇧⋆ * v"
by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)
also have "... = n(y⇧ω) * L ⊔ (y⇧⋆ * y⇧⋆ * bot ⊔ y⇧⋆ * n(y⇧ω) * L) ⊔ y⇧⋆ * y⇧⋆ * v"
by (metis mult_left_dist_sup star.circ_transitive_equal sup_bot_left mult_assoc)
also have "... = n(y⇧ω) * L ⊔ (y⇧⋆ * y⇧⋆ * bot ⊔ n(y⇧⋆ * y⇧ω) * L) ⊔ y⇧⋆ * y⇧⋆ * v"
by (simp add: n_mult_omega_L_star_zero)
also have "... = n(y⇧ω) * L ⊔ n(y⇧⋆ * y⇧ω) * L ⊔ y⇧⋆ * y⇧⋆ * v"
by (smt (z3) mult_left_dist_sup sup.left_commute sup_bot_left sup_commute)
finally show ?thesis
by (simp add: star.circ_transitive_equal star_mult_omega while_def)
qed
lemma star_below_while:
"x⇧⋆ * y ≤ x ⋆ y"
by (simp add: while_def)
subclass bounded_binary_itering
proof unfold_locales
fix x y z
have "z ⊔ x * ((y * x) ⋆ (y * z)) = x * (y * x)⇧⋆ * y * z ⊔ x * n((y * x)⇧ω) * L ⊔ z"
using mult_left_dist_sup sup_commute while_def mult_assoc by auto
also have "... = x * (y * x)⇧⋆ * y * z ⊔ n(x * (y * x)⇧ω) * L ⊔ z"
by (metis mult_assoc mult_right_isotone bot_least n_mult_omega_L_star_zero sup_relative_same_increasing)
also have "... = (x * y)⇧⋆ * z ⊔ n(x * (y * x)⇧ω) * L"
by (smt sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star_slide)
also have "... = (x * y) ⋆ z"
by (simp add: omega_slide sup_monoid.add_commute while_def)
finally show "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
by simp
next
fix x y z
have "(x ⋆ y) ⋆ (x ⋆ z) = n((n(x⇧ω) * L ⊔ x⇧⋆ * y)⇧ω) * L ⊔ (n(x⇧ω) * L ⊔ x⇧⋆ * y)⇧⋆ * (x ⋆ z)"
by (simp add: while_def)
also have "... = n((x⇧⋆ * y)⇧ω ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L) * L ⊔ ((x⇧⋆ * y)⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L) * (x ⋆ z)"
using mult_L_sup_omega mult_L_sup_star by force
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ n((x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L) * L ⊔ (x⇧⋆ * y)⇧⋆ * (x ⋆ z) ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L * (x ⋆ z)"
by (simp add: mult_right_dist_sup n_dist_omega_star sup_assoc mult_assoc)
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ n((x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L) * L ⊔ (x⇧⋆ * y)⇧⋆ * bot ⊔ (x⇧⋆ * y)⇧⋆ * (x ⋆ z) ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L * (x ⋆ z)"
by (smt sup_assoc sup_bot_left mult_left_dist_sup)
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L * (x ⋆ z) ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * (x ⋆ z))"
by (smt n_n_L_split_n_n_L_L sup_commute sup_assoc)
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * (x ⋆ z))"
by (smt mult_L_omega omega_sub_vector le_iff_sup)
also have "... = n((x⇧⋆ * y)⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * (x ⋆ z)"
using mult_left_sub_dist_sup_left sup_absorb2 while_def mult_assoc by auto
also have "... = (x⇧⋆ * y)⇧⋆ * x⇧⋆ * z ⊔ (x⇧⋆ * y)⇧⋆ * n(x⇧ω) * L ⊔ n((x⇧⋆ * y)⇧ω) * L"
by (simp add: mult_left_dist_sup sup_commute while_def mult_assoc)
also have "... = (x⇧⋆ * y)⇧⋆ * x⇧⋆ * z ⊔ n((x⇧⋆ * y)⇧⋆ * x⇧ω) * L ⊔ n((x⇧⋆ * y)⇧ω) * L"
by (metis sup_bot_right mult_left_dist_sup sup_assoc n_mult_omega_L_star_zero)
also have "... = (x ⊔ y) ⋆ z"
using n_dist_omega_star omega_decompose semiring.combine_common_factor star.circ_sup_9 sup_commute while_def by force
finally show "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
by simp
next
fix x y z
show "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
using semiring.distrib_left sup_assoc sup_commute while_def by force
next
fix x y z
show "(x ⋆ y) * z ≤ x ⋆ (y * z)"
by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def)
next
fix v w x y z
show "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
proof
assume 1: "x * z ≤ z * (y ⋆ 1) ⊔ w"
have "z * v ⊔ x * (z * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))) ≤ z * v ⊔ x * z * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))"
by (metis sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ)
also have "... ≤ z * v ⊔ z * (y ⋆ 1) * (y ⋆ v) ⊔ w * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))"
using 1 by (metis sup_assoc sup_left_isotone sup_right_isotone mult_left_isotone mult_right_dist_sup)
also have "... ≤ z * v ⊔ z * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))"
by (smt (verit, ccfv_threshold) sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_loop_fixpoint while_one_mult_while_below_1 le_supE le_supI)
also have "... = z * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))"
by (metis le_iff_sup le_supE mult_right_isotone star.circ_loop_fixpoint star_below_while)
finally have "x⇧⋆ * z * v ≤ z * (y ⋆ v) ⊔ x⇧⋆ * (w * (y ⋆ v))"
using star_left_induct mult_assoc by auto
thus "x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
by (smt sup_assoc sup_commute sup_right_isotone mult_assoc while_def)
qed
next
fix v w x y z
show "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
proof
assume "z * x ≤ y * (y ⋆ z) ⊔ w"
hence 1: "z * x ≤ y * y⇧⋆ * z ⊔ (y * n(y⇧ω) * L ⊔ w)"
by (simp add: mult_left_dist_sup sup.left_commute sup_commute while_def mult_assoc)
hence "z * x⇧⋆ ≤ y⇧⋆ * (z ⊔ (y * n(y⇧ω) * L ⊔ w) * x⇧⋆)"
by (simp add: star_circ_simulate_right_plus)
also have "... = y⇧⋆ * z ⊔ y⇧⋆ * y * n(y⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (simp add: L_mult_star semiring.distrib_left semiring.distrib_right sup_left_commute sup_monoid.add_commute mult_assoc)
also have "... = y⇧⋆ * z ⊔ n(y⇧⋆ * y * y⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (metis sup_relative_same_increasing mult_isotone n_mult_omega_L_star_zero star.left_plus_below_circ star.right_plus_circ bot_least)
also have "... = n(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * x⇧⋆"
using omega_unfold star_mult_omega sup_commute mult_assoc by force
finally have "z * x⇧⋆ * v ≤ n(y⇧ω) * L * v ⊔ y⇧⋆ * z * v ⊔ y⇧⋆ * w * x⇧⋆ * v"
by (smt le_iff_sup mult_right_dist_sup)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (z * v ⊔ w * x⇧⋆ * v)"
by (metis n_L_below_L mult_assoc mult_right_isotone sup_left_isotone mult_left_dist_sup sup_assoc)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (z * v ⊔ w * (x ⋆ v))"
using mult_right_isotone semiring.add_left_mono mult_assoc star_below_while by auto
finally have 2: "z * x⇧⋆ * v ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
by (simp add: while_def)
have 3: "y⇧⋆ * y * y⇧⋆ * bot ≤ y⇧⋆ * w * x⇧ω"
by (metis sup_commute sup_bot_left mult_assoc mult_left_sub_dist_sup_left star.circ_loop_fixpoint star.circ_transitive_equal)
have "z * x⇧ω ≤ y * y⇧⋆ * z * x⇧ω ⊔ (y * n(y⇧ω) * L ⊔ w) * x⇧ω"
using 1 by (metis mult_assoc mult_left_isotone mult_right_dist_sup omega_unfold)
hence "z * x⇧ω ≤ y⇧ω ⊔ y⇧⋆ * y * n(y⇧ω) * L * x⇧ω ⊔ y⇧⋆ * w * x⇧ω"
by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup mult_right_dist_sup omega_induct star.left_plus_circ)
also have "... ≤ y⇧ω ⊔ y⇧⋆ * y * n(y⇧ω) * L ⊔ y⇧⋆ * w * x⇧ω"
by (metis sup_left_isotone sup_right_isotone mult_assoc mult_right_isotone n_L_below_L)
also have "... = y⇧ω ⊔ n(y⇧⋆ * y * y⇧ω) * L ⊔ y⇧⋆ * w * x⇧ω"
using 3 by (smt sup_assoc sup_commute sup_relative_same_increasing n_mult_omega_L_star_zero)
also have "... = y⇧ω ⊔ y⇧⋆ * w * x⇧ω"
by (metis mult_assoc omega_unfold star_mult_omega sup_commute le_iff_sup n_L_decreasing)
finally have "n(z * x⇧ω) * L ≤ n(y⇧ω) * L ⊔ n(y⇧⋆ * w * x⇧ω) * L"
by (metis mult_assoc mult_left_isotone mult_right_dist_sup n_dist_omega_star n_isotone)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (w * (n(x⇧ω) * L ⊔ x⇧⋆ * bot))"
by (smt sup_commute sup_right_isotone mult_assoc mult_left_dist_sup n_mult_omega_L_below_zero)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (w * (n(x⇧ω) * L ⊔ x⇧⋆ * v))"
by (metis sup_right_isotone mult_right_isotone bot_least)
also have "... ≤ n(y⇧ω) * L ⊔ y⇧⋆ * (z * v ⊔ w * (n(x⇧ω) * L ⊔ x⇧⋆ * v))"
using mult_left_sub_dist_sup_right sup_right_isotone by auto
finally have 4: "n(z * x⇧ω) * L ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
using while_def by auto
have "z * (x ⋆ v) = z * n(x⇧ω) * L ⊔ z * x⇧⋆ * v"
by (simp add: mult_left_dist_sup while_def mult_assoc)
also have "... = n(z * x⇧ω) * L ⊔ z * x⇧⋆ * v"
by (metis sup_commute sup_relative_same_increasing mult_right_isotone n_mult_omega_L_star_zero bot_least)
finally show "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
using 2 4 by simp
qed
qed
lemma while_top:
"top ⋆ x = L ⊔ top * x"
by (metis n_top_L star.circ_top star_omega_top while_def)
lemma while_one_top:
"1 ⋆ x = L ⊔ x"
by (smt mult_left_one n_top_L omega_one star_one while_def)
lemma while_finite_associative:
"x⇧ω = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
by (metis sup_bot_left mult_assoc n_zero_L_zero while_def)
lemma while_while_one:
"y ⋆ (x ⋆ 1) = n(y⇧ω) * L ⊔ y⇧⋆ * n(x⇧ω) * L ⊔ y⇧⋆ * x⇧⋆"
by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)
text ‹AACP Theorem 8.17›
subclass bounded_extended_binary_itering
proof unfold_locales
fix w x y z
have "w * (x ⋆ y * z) = n(w * n(x⇧ω) * L) * L ⊔ w * x⇧⋆ * y * z"
by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_n_L_split_n_n_L_L while_def)
also have "... ≤ n((w * n(x⇧ω) * L)⇧ω) * L ⊔ w * x⇧⋆ * y * z"
by (simp add: mult_L_omega)
also have "... ≤ n((w * (x ⋆ y))⇧ω) * L ⊔ w * x⇧⋆ * y * z"
by (smt sup_left_isotone sup_ge1 mult_assoc mult_left_isotone mult_right_isotone n_isotone omega_isotone while_def)
also have "... ≤ n((w * (x ⋆ y))⇧ω) * L ⊔ w * (x ⋆ y) * z"
by (metis star_below_while mult_assoc mult_left_isotone mult_right_isotone sup_right_isotone)
also have "... ≤ n((w * (x ⋆ y))⇧ω) * L ⊔ (w * (x ⋆ y))⇧⋆ * (w * (x ⋆ y) * z)"
using sup.boundedI sup.cobounded1 while_def while_increasing by auto
finally show "w * (x ⋆ y * z) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)"
using while_def by auto
qed
subclass extended_binary_itering_apx
apply unfold_locales
by (metis n_below_n_omega n_left_upper_bound n_n_L order_trans while_def)
lemma while_simulate_4_plus:
assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
shows "y * x * x⇧⋆ ≤ x * (x ⋆ (1 ⊔ y))"
proof -
have "x * (x ⋆ (1 ⊔ y)) = x * n(x⇧ω) * L ⊔ x * x⇧⋆ * (1 ⊔ y)"
by (simp add: mult_left_dist_sup while_def mult_assoc)
also have "... = n(x * x⇧ω) * L ⊔ x * x⇧⋆ * (1 ⊔ y)"
by (smt n_mult_omega_L_star_zero sup_relative_same_increasing sup_commute sup_bot_right mult_left_sub_dist_sup_right)
finally have 1: "x * (x ⋆ (1 ⊔ y)) = n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
using mult_left_dist_sup omega_unfold sup_assoc by force
hence "x * x⇧⋆ * y * x ≤ x * x⇧⋆ * n(x⇧ω) * L ⊔ x * x⇧⋆ * x⇧⋆ * x ⊔ x * x⇧⋆ * x * x⇧⋆ * y"
by (metis assms mult_assoc mult_right_isotone mult_left_dist_sup star_plus)
also have "... = n(x * x⇧⋆ * x⇧ω) * L ⊔ x * x⇧⋆ * x⇧⋆ * x ⊔ x * x⇧⋆ * x * x⇧⋆ * y"
by (smt (z3) sup_commute n_mult_omega_L_star omega_unfold semiring.distrib_left star_plus mult_assoc)
also have "... = n(x⇧ω) * L ⊔ x * x⇧⋆ * x ⊔ x * x * x⇧⋆ * y"
using omega_unfold star.circ_plus_same star.circ_transitive_equal star_mult_omega mult_assoc by auto
also have "... ≤ n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
finally have 2: "x * x⇧⋆ * y * x ≤ n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
.
have "(n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y) * x ≤ n(x⇧ω) * L ⊔ x * x⇧⋆ * x ⊔ x * x⇧⋆ * y * x"
by (metis mult_right_dist_sup n_L_below_L mult_assoc mult_right_isotone sup_left_isotone)
also have "... ≤ n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y * x"
by (smt sup_commute sup_left_isotone mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
also have "... ≤ n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
using 2 by simp
finally show ?thesis
using 1 assms star_right_induct by force
qed
lemma while_simulate_4_omega:
assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
shows "y * x⇧ω ≤ x⇧ω"
proof -
have "x * (x ⋆ (1 ⊔ y)) = x * n(x⇧ω) * L ⊔ x * x⇧⋆ * (1 ⊔ y)"
using mult_left_dist_sup while_def mult_assoc by auto
also have "... = n(x * x⇧ω) * L ⊔ x * x⇧⋆ * (1 ⊔ y)"
by (smt (z3) mult_1_right mult_left_sub_dist_sup_left n_mult_omega_L_star sup_commute sup_relative_same_increasing)
finally have "x * (x ⋆ (1 ⊔ y)) = n(x⇧ω) * L ⊔ x * x⇧⋆ ⊔ x * x⇧⋆ * y"
using mult_left_dist_sup omega_unfold sup_assoc by force
hence "y * x⇧ω ≤ n(x⇧ω) * L * x⇧ω ⊔ x * x⇧⋆ * x⇧ω ⊔ x * x⇧⋆ * y * x⇧ω"
by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
also have "... ≤ x * x⇧⋆ * (y * x⇧ω) ⊔ x⇧ω"
by (metis sup_left_isotone mult_L_omega omega_sub_vector mult_assoc omega_unfold star_mult_omega n_L_decreasing le_iff_sup sup_commute)
finally have "y * x⇧ω ≤ (x * x⇧⋆)⇧ω ⊔ (x * x⇧⋆)⇧⋆ * x⇧ω"
by (simp add: omega_induct sup_monoid.add_commute)
thus ?thesis
by (metis sup_idem left_plus_omega star_mult_omega)
qed
lemma while_square_1:
"x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)"
by (metis mult_1_right omega_square star_square_2 while_def)
lemma while_absorb_below_one:
"y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x"
by (metis star_left_induct_mult sup_mono n_galois n_sub_nL while_def while_one_top)
lemma while_mult_L:
"(x * L) ⋆ z = z ⊔ x * L"
by (metis sup_bot_right mult_left_zero while_denest_5 while_one_top while_productstar while_sumstar)
lemma tarski_top_omega_below_2:
"x * L ≤ (x * L) ⋆ bot"
by (simp add: while_mult_L)
lemma tarski_top_omega_2:
"x * L = (x * L) ⋆ bot"
by (simp add: while_mult_L)
end
class n_omega_algebra_binary_strict = n_omega_algebra_binary + circ +
assumes L_left_zero: "L * x = L"
assumes circ_def: "x⇧∘ = n(x⇧ω) * L ⊔ x⇧⋆"
begin
subclass strict_binary_itering
apply unfold_locales
apply (metis while_def mult_assoc L_left_zero mult_right_dist_sup)
by (metis circ_def while_def mult_1_right)
end
end
Theory N_Relation_Algebras
section ‹N-Relation-Algebras›
theory N_Relation_Algebras
imports Stone_Relation_Algebras.Relation_Algebras N_Omega_Algebras
begin
context bounded_distrib_allegory
begin
subclass lattice_ordered_pre_left_semiring ..
end
text ‹Theorem 37›
sublocale relation_algebra < n_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top
apply unfold_locales
using N_comp_top comp_inf.semiring.distrib_left inf.sup_monoid.add_commute inf_vector_comp apply simp
apply (metis N_comp compl_sup double_compl mult_assoc mult_right_dist_sup top_mult_top N_comp_N)
apply (metis brouwer.p_antitone inf.sup_monoid.add_commute inf.sup_right_isotone mult_left_isotone p_antitone_sup)
apply simp
using N_vector_top apply force
apply simp
apply (simp add: brouwer.p_antitone_iff top_right_mult_increasing)
apply simp
apply (metis N_comp_top conv_complement_sub double_compl le_supI2 le_iff_sup mult_assoc mult_left_isotone schroeder_3)
by simp
sublocale relation_algebra < n_algebra_apx where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq
apply unfold_locales
using n_less_eq_char by force
no_notation
inverse_divide (infixl "'/" 70)
notation
divide (infixl "'/" 70)
class left_residuated_relation_algebra = relation_algebra + inverse +
assumes lres_def: "x / y = -(-x * y⇧T)"
begin
text ‹Theorem 32.1›
subclass residuated_pre_left_semiring
apply unfold_locales
by (metis compl_le_swap1 lres_def schroeder_4)
end
context left_residuated_relation_algebra
begin
text ‹Theorem 32.3›
lemma lres_mult_lres_lres:
"x / (z * y) = (x / y) / z"
by (metis conv_dist_comp double_compl lres_def mult_assoc)
text ‹Theorem 32.5›
lemma lres_dist_inf:
"(x ⊓ y) / z = (x / z) ⊓ (y / z)"
by (metis compl_inf compl_sup lres_def mult_right_dist_sup)
text ‹Theorem 32.6›
lemma lres_add_export_vector:
assumes "vector x"
shows "(x ⊔ y) / z = x ⊔ (y / z)"
proof -
have "(x ⊔ y) / z = -((-x ⊓ -y) * z⇧T)"
by (simp add: lres_def)
also have "... = -(-x ⊓ (-y * z⇧T))"
using assms vector_complement_closed vector_inf_comp by auto
also have "... = x ⊔ (y / z)"
by (simp add: lres_def)
finally show ?thesis
.
qed
text ‹Theorem 32.7›
lemma lres_top_vector:
"vector (x / top)"
using equivalence_top_closed lres_def vector_complement_closed vector_mult_closed vector_top_closed by auto
text ‹Theorem 32.10›
lemma lres_top_export_inf_mult:
"((x / top) ⊓ y) * z = (x / top) ⊓ (y * z)"
by (simp add: vector_inf_comp lres_top_vector)
lemma N_lres:
"N(x) = x / top ⊓ 1"
using lres_def by auto
end
class complete_relation_algebra = relation_algebra + complete_lattice
begin
definition mu :: "('a ⇒ 'a) ⇒ 'a" where "mu f ≡ Inf { y . f y ≤ y }"
definition nu :: "('a ⇒ 'a) ⇒ 'a" where "nu f ≡ Sup { y . y ≤ f y }"
lemma mu_lower_bound:
"f x ≤ x ⟹ mu f ≤ x"
by (auto simp add: mu_def intro: Inf_lower)
lemma mu_greatest_lower_bound:
"(∀y . f y ≤ y ⟶ x ≤ y) ⟹ x ≤ mu f"
using lfp_def lfp_greatest mu_def by auto
lemma mu_unfold_1:
"isotone f ⟹ f (mu f) ≤ mu f"
by (metis mu_greatest_lower_bound order_trans mu_lower_bound isotone_def)
lemma mu_unfold_2:
"isotone f ⟹ mu f ≤ f (mu f)"
by (simp add: mu_lower_bound mu_unfold_1 ord.isotone_def)
lemma mu_unfold:
"isotone f ⟹ mu f = f (mu f)"
by (simp add: order.antisym mu_unfold_1 mu_unfold_2)
lemma mu_const:
"mu (λx . y) = y"
by (simp add: isotone_def mu_unfold)
lemma mu_lpfp:
"isotone f ⟹ is_least_prefixpoint f (mu f)"
by (simp add: is_least_prefixpoint_def mu_lower_bound mu_unfold_1)
lemma mu_lfp:
"isotone f ⟹ is_least_fixpoint f (mu f)"
by (metis is_least_fixpoint_def mu_lower_bound mu_unfold order_refl)
lemma mu_pmu:
"isotone f ⟹ pμ f = mu f"
using least_prefixpoint_same mu_lpfp by force
lemma mu_mu:
"isotone f ⟹ μ f = mu f"
using least_fixpoint_same mu_lfp by fastforce
end
class omega_relation_algebra = relation_algebra + star + omega +
assumes ra_star_left_unfold : "1 ⊔ y * y⇧⋆ ≤ y⇧⋆"
assumes ra_star_left_induct : "z ⊔ y * x ≤ x ⟶ y⇧⋆ * z ≤ x"
assumes ra_star_right_induct: "z ⊔ x * y ≤ x ⟶ z * y⇧⋆ ≤ x"
assumes ra_omega_unfold: "y⇧ω = y * y⇧ω"
assumes ra_omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧ω ⊔ y⇧⋆ * z"
begin
subclass bounded_omega_algebra
apply unfold_locales
using ra_star_left_unfold apply blast
using ra_star_left_induct apply blast
using ra_star_right_induct apply blast
using ra_omega_unfold apply blast
using ra_omega_induct by blast
end
text ‹Theorem 38›
sublocale omega_relation_algebra < n_omega_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq and Omega = "λx . N(x⇧ω) * top ⊔ x⇧⋆"
apply unfold_locales
apply simp
using n_split_omega_mult omega_vector star_mult_omega apply force
by simp
end
Theory Domain
section ‹Domain›
theory Domain
imports Stone_Relation_Algebras.Semirings Tests
begin
context idempotent_left_semiring
begin
sublocale ils: il_semiring where inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
apply unfold_locales
apply (simp add: sup_assoc)
apply (simp add: sup_commute)
apply simp
apply simp
apply (simp add: mult_assoc)
apply (simp add: mult_right_dist_sup)
apply simp
apply simp
apply simp
apply (simp add: mult_right_isotone)
apply (simp add: le_iff_sup)
by (simp add: less_le_not_le)
end
class left_zero_domain_semiring = idempotent_left_zero_semiring + dom +
assumes d_restrict: "x ⊔ d(x) * x = d(x) * x"
assumes d_mult_d : "d(x * y) = d(x * d(y))"
assumes d_plus_one: "d(x) ⊔ 1 = 1"
assumes d_zero : "d(bot) = bot"
assumes d_dist_sup: "d(x ⊔ y) = d(x) ⊔ d(y)"
begin
text ‹Many lemmas in this class are taken from Georg Struth's theories.›
lemma d_restrict_equals:
"x = d(x) * x"
by (metis sup_commute d_plus_one d_restrict mult_left_one mult_right_dist_sup)
lemma d_involutive:
"d(d(x)) = d(x)"
by (metis d_mult_d mult_left_one)
lemma d_fixpoint:
"(∃y . x = d(y)) ⟷ x = d(x)"
using d_involutive by auto
lemma d_type:
"∀P . (∀x . x = d(x) ⟶ P(x)) ⟷ (∀x . P(d(x)))"
by (metis d_involutive)
lemma d_mult_sub:
"d(x * y) ≤ d(x)"
by (metis d_dist_sup d_mult_d d_plus_one le_iff_sup mult_left_sub_dist_sup_left mult_1_right)
lemma d_sub_one:
"x ≤ 1 ⟹ x ≤ d(x)"
by (metis d_restrict_equals mult_right_isotone mult_1_right)
lemma d_strict:
"d(x) = bot ⟷ x = bot"
by (metis d_restrict_equals d_zero mult_left_zero)
lemma d_one:
"d(1) = 1"
by (metis d_restrict_equals mult_1_right)
lemma d_below_one:
"d(x) ≤ 1"
by (simp add: d_plus_one le_iff_sup)
lemma d_isotone:
"x ≤ y ⟹ d(x) ≤ d(y)"
by (metis d_dist_sup le_iff_sup)
lemma d_plus_left_upper_bound:
"d(x) ≤ d(x ⊔ y)"
by (simp add: d_isotone)
lemma d_export:
"d(d(x) * y) = d(x) * d(y)"
apply (rule order.antisym)
apply (metis d_below_one d_involutive d_mult_sub d_restrict_equals d_isotone d_mult_d mult_isotone mult_left_one)
by (metis d_below_one d_sub_one coreflexive_mult_closed d_mult_d)
lemma d_idempotent:
"d(x) * d(x) = d(x)"
by (metis d_export d_restrict_equals)
lemma d_commutative:
"d(x) * d(y) = d(y) * d(x)"
by (metis ils.il_inf_associative order.antisym d_export d_mult_d d_mult_sub d_one d_restrict_equals mult_isotone mult_left_one)
lemma d_least_left_preserver:
"x ≤ d(y) * x ⟷ d(x) ≤ d(y)"
by (metis d_below_one d_involutive d_mult_sub d_restrict_equals order.eq_iff mult_left_isotone mult_left_one)
lemma d_weak_locality:
"x * y = bot ⟷ x * d(y) = bot"
by (metis d_mult_d d_strict)
lemma d_sup_closed:
"d(d(x) ⊔ d(y)) = d(x) ⊔ d(y)"
by (simp add: d_involutive d_dist_sup)
lemma d_mult_closed:
"d(d(x) * d(y)) = d(x) * d(y)"
using d_export d_mult_d by auto
lemma d_mult_left_lower_bound:
"d(x) * d(y) ≤ d(x)"
by (metis d_export d_involutive d_mult_sub)
lemma d_mult_greatest_lower_bound:
"d(x) ≤ d(y) * d(z) ⟷ d(x) ≤ d(y) ∧ d(x) ≤ d(z)"
by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)
lemma d_mult_left_absorb_sup:
"d(x) * (d(x) ⊔ d(y)) = d(x)"
by (metis sup_commute d_idempotent d_plus_one mult_left_dist_sup mult_1_right)
lemma d_sup_left_absorb_mult:
"d(x) ⊔ d(x) * d(y) = d(x)"
using d_mult_left_lower_bound sup.absorb_iff1 by auto
lemma d_sup_left_dist_mult:
"d(x) ⊔ d(y) * d(z) = (d(x) ⊔ d(y)) * (d(x) ⊔ d(z))"
by (smt sup_assoc d_commutative d_idempotent d_mult_left_absorb_sup mult_left_dist_sup mult_right_dist_sup)
lemma d_order:
"d(x) ≤ d(y) ⟷ d(x) = d(x) * d(y)"
by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)
lemma d_mult_below:
"d(x) * y ≤ y"
by (metis sup_left_divisibility d_plus_one mult_left_one mult_right_dist_sup)
lemma d_preserves_equation:
"d(y) * x ≤ x * d(y) ⟷ d(y) * x = d(y) * x * d(y)"
by (simp add: d_below_one d_idempotent test_preserves_equation)
end
class left_zero_antidomain_semiring = idempotent_left_zero_semiring + dom + uminus +
assumes a_restrict : "-x * x = bot"
assumes a_plus_mult_d: "-(x * y) ⊔ -(x * --y) = -(x * --y)"
assumes a_complement : "--x ⊔ -x = 1"
assumes d_def : "d(x) = --x"
begin
sublocale aa: a_algebra where minus = "λx y . -(-x ⊔ y)" and uminus = uminus and inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
apply unfold_locales
apply (simp add: a_restrict)
using a_complement sup_commute apply fastforce
apply (simp add: a_plus_mult_d le_iff_sup)
by simp
subclass left_zero_domain_semiring
apply unfold_locales
apply (simp add: d_def aa.double_complement_above)
apply (simp add: aa.a_d.d3_eq d_def)
apply (simp add: d_def)
apply (simp add: d_def)
by (simp add: d_def aa.l15)
subclass tests
apply unfold_locales
apply (simp add: mult_assoc)
apply (simp add: aa.sba_dual.sub_commutative)
apply (simp add: aa.sba_dual.sub_complement)
using aa.sba_dual.sub_sup_closed apply simp
apply simp
apply simp
apply (simp add: aa.sba_dual.sub_inf_def)
apply (simp add: aa.less_eq_inf)
by (simp add: less_le_not_le)
text ‹Many lemmas in this class are taken from Georg Struth's theories.›
notation
uminus ("a")
lemma a_greatest_left_absorber:
"a(x) * y = bot ⟷ a(x) ≤ a(y)"
by (simp add: aa.l10_iff)
lemma a_mult_d:
"a(x * y) = a(x * d(y))"
by (simp add: d_def aa.sba3_complement_inf_double_complement)
lemma a_d_closed:
"d(a(x)) = a(x)"
by (simp add: d_def)
lemma a_plus_left_lower_bound:
"a(x ⊔ y) ≤ a(x)"
by (simp add: aa.l9)
lemma a_mult_sup:
"a(x) * (y ⊔ x) = a(x) * y"
by (simp add: aa.sba3_inf_complement_bot semiring.distrib_left)
lemma a_3:
"a(x) * a(y) * d(x ⊔ y) = bot"
using d_weak_locality aa.l12 aa.sba3_inf_complement_bot by force
lemma a_export:
"a(a(x) * y) = d(x) ⊔ a(y)"
using a_mult_d d_def aa.sba_dual.sub_inf_def by auto
lemma a_fixpoint:
"∀x . (a(x) = x ⟶ (∀y . y = bot))"
by (metis aa.a_d.d_fully_strict aa.sba2_bot_unit aa.sup_idempotent aa.sup_right_zero_var)
lemma a_strict:
"a(x) = 1 ⟷ x = bot"
using aa.a_d.d_fully_strict one_def by fastforce
lemma d_complement_zero:
"d(x) * a(x) = bot"
by (simp add: aa.sba3_inf_complement_bot d_def)
lemma a_complement_zero:
"a(x) * d(x) = bot"
by (simp add: d_def)
lemma a_shunting_zero:
"a(x) * d(y) = bot ⟷ a(x) ≤ a(y)"
by (simp add: aa.less_eq_inf_bot d_def)
lemma a_antitone:
"x ≤ y ⟹ a(y) ≤ a(x)"
by (simp add: aa.l9)
lemma a_mult_deMorgan:
"a(a(x) * a(y)) = d(x ⊔ y)"
by (simp add: aa.sup_demorgan d_def)
lemma a_mult_deMorgan_1:
"a(a(x) * a(y)) = d(x) ⊔ d(y)"
by (simp add: a_export d_def)
lemma a_mult_deMorgan_2:
"a(d(x) * d(y)) = a(x) ⊔ a(y)"
by (simp add: d_def sup_def)
lemma a_plus_deMorgan:
"a(a(x) ⊔ a(y)) = d(x) * d(y)"
by (simp add: aa.sub_sup_demorgan d_def)
lemma a_plus_deMorgan_1:
"a(d(x) ⊔ d(y)) = a(x) * a(y)"
by (simp add: aa.sup_demorgan d_def)
lemma a_mult_left_upper_bound:
"a(x) ≤ a(x * y)"
using aa.l5 d_def d_mult_sub by auto
lemma d_a_closed:
"a(d(x)) = a(x)"
by (simp add: d_def)
lemma a_export_d:
"a(d(x) * y) = a(x) ⊔ a(y)"
using a_mult_d a_mult_deMorgan_2 by auto
lemma a_7:
"d(x) * a(d(y) ⊔ d(z)) = d(x) * a(y) * a(z)"
by (simp add: a_plus_deMorgan_1 mult_assoc)
lemma d_a_shunting:
"d(x) * a(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ d(y)"
using aa.sba_dual.shunting_right d_def by auto
lemma d_d_shunting:
"d(x) * d(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ a(y)"
using d_a_shunting d_def by auto
lemma d_cancellation_1:
"d(x) ≤ d(y) ⊔ (d(x) * a(y))"
by (metis a_d_closed aa.sba2_export aa.sup_demorgan d_def eq_refl le_supE sup_commute)
lemma d_cancellation_2:
"(d(z) ⊔ d(y)) * a(y) ≤ d(z)"
by (metis d_a_shunting d_dist_sup eq_refl)
lemma a_sup_closed:
"d(a(x) ⊔ a(y)) = a(x) ⊔ a(y)"
using aa.sub_sup_closed d_def by auto
lemma a_mult_closed:
"d(a(x) * a(y)) = a(x) * a(y)"
using a_d_closed aa.l12 by auto
lemma d_a_shunting_zero:
"d(x) * a(y) = bot ⟷ d(x) ≤ d(y)"
by (simp add: aa.l10_iff d_def)
lemma d_d_shunting_zero:
"d(x) * d(y) = bot ⟷ d(x) ≤ a(y)"
by (simp add: aa.l10_iff d_def)
lemma d_compl_intro:
"d(x) ⊔ d(y) = d(x) ⊔ a(x) * d(y)"
by (simp add: aa.sup_complement_intro d_def)
lemma a_compl_intro:
"a(x) ⊔ a(y) = a(x) ⊔ d(x) * a(y)"
by (simp add: aa.sup_complement_intro d_def)
lemma kat_2:
"y * a(z) ≤ a(x) * y ⟹ d(x) * y * a(z) = bot"
by (smt a_export a_plus_left_lower_bound le_sup_iff d_d_shunting_zero d_export d_strict le_iff_sup mult_assoc)
lemma kat_3:
"d(x) * y * a(z) = bot ⟹ d(x) * y = d(x) * y * d(z)"
by (metis a_export_d aa.complement_bot d_complement_zero d_def mult_1_right mult_left_dist_sup sup_bot_left)
lemma kat_4:
"d(x) * y = d(x) * y * d(z) ⟹ d(x) * y ≤ y * d(z)"
using d_mult_below mult_assoc by auto
lemma kat_2_equiv:
"y * a(z) ≤ a(x) * y ⟷ d(x) * y * a(z) = bot"
apply (rule iffI)
apply (simp add: kat_2)
by (metis aa.top_greatest a_complement sup_bot_left d_def mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)
lemma kat_4_equiv:
"d(x) * y = d(x) * y * d(z) ⟷ d(x) * y ≤ y * d(z)"
apply (rule iffI)
apply (simp add: kat_4)
apply (rule order.antisym)
apply (metis d_idempotent le_iff_sup mult_assoc mult_left_dist_sup)
by (metis d_plus_one le_iff_sup mult_left_dist_sup mult_1_right)
lemma kat_3_equiv_opp:
"a(z) * y * d(x) = bot ⟷ y * d(x) = d(z) * y * d(x)"
by (metis a_complement a_restrict sup_bot_left d_a_closed d_def mult_assoc mult_left_one mult_left_zero mult_right_dist_sup)
lemma kat_4_equiv_opp:
"y * d(x) = d(z) * y * d(x) ⟷ y * d(x) ≤ d(z) * y"
using kat_2_equiv kat_3_equiv_opp d_def by auto
lemma d_restrict_iff:
"(x ≤ y) ⟷ (x ≤ d(x) * y)"
by (metis d_mult_below d_restrict_equals mult_isotone order_lesseq_imp)
lemma d_restrict_iff_1:
"(d(x) * y ≤ z) ⟷ (d(x) * y ≤ d(x) * z)"
by (metis sup_commute d_export d_mult_left_lower_bound d_plus_one d_restrict_iff mult_left_isotone mult_left_one mult_right_sub_dist_sup_right order_trans)
end
end
Theory Domain_Iterings
section ‹Domain Iterings›
theory Domain_Iterings
imports Domain Lattice_Ordered_Semirings Omega_Algebras
begin
class domain_semiring_lattice = left_zero_domain_semiring + lattice_ordered_pre_left_semiring
begin
subclass bounded_idempotent_left_zero_semiring ..
lemma d_top:
"d(top) = 1"
by (metis sup_left_top d_dist_sup d_one d_plus_one)
lemma mult_domain_top:
"x * d(y) * top ≤ d(x * y) * top"
by (smt d_mult_d d_restrict_equals mult_assoc mult_right_isotone top_greatest)
lemma domain_meet_domain:
"d(x ⊓ d(y) * z) ≤ d(y)"
by (metis d_export d_isotone d_mult_greatest_lower_bound inf.cobounded2)
lemma meet_domain:
"x ⊓ d(y) * z = d(y) * (x ⊓ z)"
apply (rule order.antisym)
apply (metis domain_meet_domain d_mult_below d_restrict_equals inf_mono mult_isotone)
by (meson d_mult_below le_inf_iff mult_left_sub_dist_inf_right)
lemma meet_intro_domain:
"x ⊓ y = d(y) * x ⊓ y"
by (metis d_restrict_equals inf_commute meet_domain)
lemma meet_domain_top:
"x ⊓ d(y) * top = d(y) * x"
by (simp add: meet_domain)
lemma d_galois:
"d(x) ≤ d(y) ⟷ x ≤ d(y) * top"
by (metis d_export d_isotone d_mult_left_absorb_sup d_plus_one d_restrict_equals d_top mult_isotone top.extremum)
lemma vector_meet:
"x * top ⊓ y ≤ d(x) * y"
by (metis d_galois d_mult_sub inf.sup_monoid.add_commute inf.sup_right_isotone meet_domain_top)
end
class domain_semiring_lattice_L = domain_semiring_lattice + L +
assumes l1: "x * L = x * bot ⊔ d(x) * L"
assumes l2: "d(L) * x ≤ x * d(L)"
assumes l3: "d(L) * top ≤ L ⊔ d(L * bot) * top"
assumes l4: "L * top ≤ L"
assumes l5: "x * bot ⊓ L ≤ (x ⊓ L) * bot"
begin
lemma l8:
"(x ⊓ L) * bot ≤ x * bot ⊓ L"
by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)
lemma l9:
"x * bot ⊓ L ≤ d(x * bot) * L"
by (metis vector_meet vector_mult_closed zero_vector)
lemma l10:
"L * L = L"
by (metis d_restrict_equals l1 le_iff_sup zero_right_mult_decreasing)
lemma l11:
"d(x) * L ≤ x * L"
by (metis l1 sup.cobounded2)
lemma l12:
"d(x * bot) * L ≤ x * bot"
by (metis sup_right_divisibility l1 mult_assoc mult_left_zero)
lemma l13:
"d(x * bot) * L ≤ x"
using l12 order_trans zero_right_mult_decreasing by blast
lemma l14:
"x * L ≤ x * bot ⊔ L"
by (metis d_mult_below l1 sup_right_isotone)
lemma l15:
"x * d(y) * L = x * bot ⊔ d(x * y) * L"
by (metis d_commutative d_mult_d d_zero l1 mult_assoc mult_left_zero)
lemma l16:
"x * top ⊓ L ≤ x * L"
using inf.order_lesseq_imp l11 vector_meet by blast
lemma l17:
"d(x) * L ≤ d(x * L) * L"
by (metis d_mult_below l11 le_infE le_infI meet_intro_domain)
lemma l18:
"d(x) * L = d(x * L) * L"
by (simp add: order.antisym d_mult_sub l17 mult_left_isotone)
lemma l19:
"d(x * top * bot) * L ≤ d(x * L) * L"
by (metis d_mult_sub l18 mult_assoc mult_left_isotone)
lemma l20:
"x ≤ y ⟷ x ≤ y ⊔ L ∧ x ≤ y ⊔ d(y * bot) * top"
apply (rule iffI)
apply (simp add: le_supI1)
by (smt sup_commute sup_inf_distrib1 l13 le_iff_sup meet_domain_top)
lemma l21:
"d(x * bot) * L ≤ x * bot ⊓ L"
by (simp add: d_mult_below l12)
lemma l22:
"x * bot ⊓ L = d(x * bot) * L"
using l21 order.antisym l9 by auto
lemma l23:
"x * top ⊓ L = d(x) * L"
apply (rule order.antisym)
apply (simp add: vector_meet)
by (metis d_mult_below inf.le_sup_iff inf_top.left_neutral l1 le_supE mult_left_sub_dist_inf_left)
lemma l29:
"L * d(L) = L"
by (metis d_preserves_equation d_restrict_equals l2)
lemma l30:
"d(L) * x ≤ (x ⊓ L) ⊔ d(L * bot) * x"
by (metis inf.sup_right_divisibility inf_left_commute inf_sup_distrib1 l3 meet_domain_top)
lemma l31:
"d(L) * x = (x ⊓ L) ⊔ d(L * bot) * x"
by (smt (z3) l30 d_dist_sup le_iff_sup meet_intro_domain semiring.combine_common_factor sup_commute sup_inf_absorb zero_right_mult_decreasing)
lemma l40:
"L * x ≤ L"
by (meson bot_least inf.order_trans l4 semiring.mult_left_mono top.extremum)
lemma l41:
"L * top = L"
by (simp add: l40 order.antisym top_right_mult_increasing)
lemma l50:
"x * bot ⊓ L = (x ⊓ L) * bot"
using order.antisym l5 l8 by force
lemma l51:
"d(x * bot) * L = (x ⊓ L) * bot"
using l22 l50 by auto
lemma l90:
"L * top * L = L"
by (simp add: l41 l10)
lemma l91:
assumes "x = x * top"
shows "d(L * bot) * x ≤ d(x * bot) * top"
proof -
have "d(L * bot) * x ≤ d(d(L * bot) * x) * top"
using d_galois by blast
also have "... = d(d(L * bot) * d(x)) * top"
using d_mult_d by auto
also have "... = d(d(x) * L * bot) * top"
using d_commutative d_mult_d ils.il_inf_associative by auto
also have "... ≤ d(x * L * bot) * top"
by (metis d_isotone l11 mult_left_isotone)
also have "... ≤ d(x * top * bot) * top"
by (simp add: d_isotone mult_left_isotone mult_right_isotone)
finally show ?thesis
using assms by auto
qed
lemma l92:
assumes "x = x * top"
shows "d(L * bot) * x ≤ d((x ⊓ L) * bot) * top"
proof -
have "d(L * bot) * x = d(L) * d(L * bot) * x"
using d_commutative d_mult_sub d_order by auto
also have "... ≤ d(L) * d(x * bot) * top"
by (metis assms order.eq_iff l91 mult_assoc mult_isotone)
also have "... = d(d(x * bot) * L) * top"
by (simp add: d_commutative d_export)
also have "... ≤ d((x ⊓ L) * bot) * top"
by (simp add: l51)
finally show ?thesis
.
qed
end
class domain_itering_lattice_L = bounded_itering + domain_semiring_lattice_L
begin
lemma mult_L_circ:
"(x * L)⇧∘ = 1 ⊔ x * L"
by (metis circ_back_loop_fixpoint circ_mult l40 le_iff_sup mult_assoc)
lemma mult_L_circ_mult_below:
"(x * L)⇧∘ * y ≤ y ⊔ x * L"
by (smt sup_right_isotone l40 mult_L_circ mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone)
lemma circ_L:
"L⇧∘ = L ⊔ 1"
by (metis sup_commute l10 mult_L_circ)
lemma circ_d0_L:
"x⇧∘ * d(x * bot) * L = x⇧∘ * bot"
by (metis sup_bot_right circ_loop_fixpoint circ_plus_same d_zero l15 mult_assoc mult_left_zero)
lemma d0_circ_left_unfold:
"d(x⇧∘ * bot) = d(x * x⇧∘ * bot)"
by (metis sup_commute sup_bot_left circ_loop_fixpoint mult_assoc)
lemma d_circ_import:
"d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧∘ = d(y) * (d(y) * x)⇧∘"
apply (rule order.antisym)
apply (simp add: circ_import d_idempotent d_plus_one le_iff_sup)
using circ_isotone d_mult_below mult_right_isotone by auto
end
class domain_omega_algebra_lattice_L = bounded_left_zero_omega_algebra + domain_semiring_lattice_L
begin
lemma mult_L_star:
"(x * L)⇧⋆ = 1 ⊔ x * L"
by (metis l40 le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_mult)
lemma mult_L_omega:
"(x * L)⇧ω ≤ x * L"
by (metis l40 mult_right_isotone omega_slide)
lemma mult_L_sup_star:
"(x * L ⊔ y)⇧⋆ = y⇧⋆ ⊔ y⇧⋆ * x * L"
proof (rule order.antisym)
have "(x * L ⊔ y) * (y⇧⋆ ⊔ y⇧⋆ * x * L) = x * L * (y⇧⋆ ⊔ y⇧⋆ * x * L) ⊔ y * (y⇧⋆ ⊔ y⇧⋆ * x * L)"
by (simp add: mult_right_dist_sup)
also have "... ≤ x * L ⊔ y * (y⇧⋆ ⊔ y⇧⋆ * x * L)"
by (metis sup_left_isotone l40 mult_assoc mult_right_isotone)
also have "... ≤ x * L ⊔ y * y⇧⋆ ⊔ y⇧⋆ * x * L"
by (smt sup_assoc sup_commute sup_ge2 mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
also have "... ≤ x * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
by (meson order_refl star.left_plus_below_circ sup_mono)
also have "... = y⇧⋆ ⊔ y⇧⋆ * x * L"
by (metis sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star.circ_reflexive star.circ_sup_one_right_unfold star_involutive)
finally have "1 ⊔ (x * L ⊔ y) * (y⇧⋆ ⊔ y⇧⋆ * x * L) ≤ y⇧⋆ ⊔ y⇧⋆ * x * L"
by (meson le_supI le_supI1 star.circ_reflexive)
thus "(x * L ⊔ y)⇧⋆ ≤ y⇧⋆ ⊔ y⇧⋆ * x * L"
using star_left_induct by fastforce
next
show "y⇧⋆ ⊔ y⇧⋆ * x * L ≤ (x * L ⊔ y)⇧⋆"
by (metis sup_commute le_sup_iff mult_assoc star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
qed
lemma mult_L_sup_omega:
"(x * L ⊔ y)⇧ω ≤ y⇧ω ⊔ y⇧⋆ * x * L"
proof -
have 1: "(y⇧⋆ * x * L)⇧ω ≤ y⇧ω ⊔ y⇧⋆ * x * L"
by (simp add: le_supI2 mult_L_omega)
have "(y⇧⋆ * x * L)⇧⋆ * y⇧ω ≤ y⇧ω ⊔ y⇧⋆ * x * L"
by (metis sup_right_isotone l40 mult_assoc mult_right_isotone star_left_induct)
thus ?thesis
using 1 by (simp add: ils.il_inf_associative omega_decompose sup_monoid.add_commute)
qed
end
sublocale domain_omega_algebra_lattice_L < dL_star: itering where circ = star ..
sublocale domain_omega_algebra_lattice_L < dL_star: domain_itering_lattice_L where circ = star ..
context domain_omega_algebra_lattice_L
begin
lemma d0_star_below_d0_omega:
"d(x⇧⋆ * bot) ≤ d(x⇧ω * bot)"
by (simp add: d_isotone star_bot_below_omega_bot)
lemma d0_below_d0_omega:
"d(x * bot) ≤ d(x⇧ω * bot)"
by (metis d0_star_below_d0_omega d_isotone mult_left_isotone order_trans star.circ_increasing)
lemma star_L_split:
assumes "y ≤ z"
and "x * z * L ≤ x * bot ⊔ z * L"
shows "x⇧⋆ * y * L ≤ x⇧⋆ * bot ⊔ z * L"
proof -
have "x * (x⇧⋆ * bot ⊔ z * L) ≤ x⇧⋆ * bot ⊔ x * z * L"
by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
also have "... ≤ x⇧⋆ * bot ⊔ x * bot ⊔ z * L"
using assms(2) semiring.add_left_mono sup_monoid.add_assoc by auto
also have "... = x⇧⋆ * bot ⊔ z * L"
using mult_isotone star.circ_increasing sup.absorb_iff1 by force
finally have "y * L ⊔ x * (x⇧⋆ * bot ⊔ z * L) ≤ x⇧⋆ * bot ⊔ z * L"
by (simp add: assms(1) le_supI1 mult_left_isotone sup_monoid.add_commute)
thus ?thesis
by (simp add: star_left_induct mult.assoc)
qed
lemma star_L_split_same:
"x * y * L ≤ x * bot ⊔ y * L ⟹ x⇧⋆ * y * L = x⇧⋆ * bot ⊔ y * L"
apply (rule order.antisym)
using star_L_split apply blast
by (metis bot_least ils.il_inf_associative le_supI mult_isotone mult_left_one order_refl star.circ_reflexive)
lemma star_d_L_split_equal:
"d(x * y) ≤ d(y) ⟹ x⇧⋆ * d(y) * L = x⇧⋆ * bot ⊔ d(y) * L"
by (metis sup_right_isotone l15 le_iff_sup mult_right_sub_dist_sup_left star_L_split_same)
lemma d0_omega_mult:
"d(x⇧ω * y * bot) = d(x⇧ω * bot)"
apply (rule order.antisym)
apply (simp add: d_isotone mult_isotone omega_sub_vector)
by (metis d_isotone mult_assoc mult_right_isotone bot_least)
lemma d_omega_export:
"d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧ω = (d(y) * x)⇧ω"
apply (rule order.antisym)
apply (simp add: d_preserves_equation omega_simulation)
by (smt le_iff_sup mult_left_dist_sup omega_simulation_2 omega_slide)
lemma d_omega_import:
"d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧ω = d(y) * (d(y) * x)⇧ω"
using d_idempotent omega_import order.refl by auto
lemma star_d_omega_top:
"x⇧⋆ * d(x⇧ω) * top = x⇧⋆ * bot ⊔ d(x⇧ω) * top"
apply (rule order.antisym)
apply (metis le_supI2 mult_domain_top star_mult_omega)
by (metis ils.il_inf_associative le_supI mult_left_one mult_left_sub_dist_sup_right mult_right_sub_dist_sup_left star.circ_right_unfold_1 sup_monoid.add_0_right)
lemma omega_meet_L:
"x⇧ω ⊓ L = d(x⇧ω) * L"
by (metis l23 omega_vector)
end
end
Theory Domain_Recursion
section ‹Domain Recursion›
theory Domain_Recursion
imports Domain_Iterings Approximation
begin
class domain_semiring_lattice_apx = domain_semiring_lattice_L + apx +
assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
begin
lemma apx_transitive:
assumes "x ⊑ y"
and "y ⊑ z"
shows "x ⊑ z"
proof -
have 1: "x ≤ z ⊔ L"
by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
have "d(d(L) * y * bot) * top ≤ d((x ⊔ d(x * bot) * top) * bot) * top"
by (metis assms(1) apx_def d_isotone mult_left_isotone)
also have "... ≤ d(x * bot) * top"
by (metis le_sup_iff d_galois mult_left_isotone mult_right_dist_sup order_refl zero_right_mult_decreasing)
finally have 2: "d(d(L) * y * bot) * top ≤ d(x * bot) * top"
.
have "d(L) * z = d(L) * (d(L) * z)"
by (simp add: d_idempotent ils.il_inf_associative)
also have "... ≤ d(L) * y ⊔ d(d(L) * y * bot) * top"
by (metis assms(2) apx_def d_export mult_assoc mult_left_dist_sup mult_right_isotone)
also have "... ≤ x ⊔ d(x * bot) * top"
using 2 by (meson assms(1) apx_def le_supI2 sup_least)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
lemma apx_meet_L:
assumes "y ⊑ x"
shows "x ⊓ L ≤ y ⊓ L"
proof -
have "x ⊓ L = d(L) * x ⊓ L"
using meet_intro_domain by auto
also have "... ≤ (y ⊔ d(y * bot) * top) ⊓ L"
using assms apx_def inf.sup_left_isotone by blast
also have "... ≤ y"
by (simp add: inf.sup_monoid.add_commute inf_sup_distrib1 l13 meet_domain_top)
finally show ?thesis
by simp
qed
lemma sup_apx_left_isotone:
assumes "x ⊑ y"
shows "x ⊔ z ⊑ y ⊔ z"
proof -
have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
have "d(L) * (y ⊔ z) = d(L) * y ⊔ d(L) * z"
by (simp add: mult_left_dist_sup)
also have "... ≤ d(L) * y ⊔ z"
by (simp add: d_mult_below le_supI1 sup_commute)
also have "... ≤ x ⊔ d(x * bot) * top ⊔ z"
using assms apx_def sup_left_isotone by blast
also have "... ≤ x ⊔ z ⊔ d((x ⊔ z) * bot) * top"
by (simp add: d_dist_sup le_iff_sup semiring.distrib_right sup.left_commute sup_monoid.add_assoc)
finally show ?thesis
using 1 by (simp add: apx_def)
qed
subclass apx_biorder
apply unfold_locales
apply (metis le_sup_iff sup_ge1 apx_def d_plus_one mult_left_one mult_right_dist_sup)
apply (meson apx_meet_L order.antisym apx_def relative_equality sup_same_context)
using apx_transitive by blast
lemma mult_apx_left_isotone:
assumes "x ⊑ y"
shows "x * z ⊑ y * z"
proof -
have "x * z ≤ y * z ⊔ L * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
hence 1: "x * z ≤ y * z ⊔ L"
using l40 order_lesseq_imp semiring.add_left_mono by blast
have "d(L) * y * z ≤ x * z ⊔ d(x * bot) * top * z"
by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
also have "... ≤ x * z ⊔ d(x * z * bot) * top"
by (metis sup_right_isotone d_isotone mult_assoc mult_isotone mult_right_isotone top_greatest bot_least)
finally show ?thesis
using 1 by (simp add: apx_def mult_assoc)
qed
lemma mult_apx_right_isotone:
assumes "x ⊑ y"
shows "z * x ⊑ z * y"
proof -
have "z * x ≤ z * y ⊔ z * L"
by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
also have "... ≤ z * y ⊔ z * bot ⊔ L"
using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
finally have 1: "z * x ≤ z * y ⊔ L"
using mult_right_isotone sup.order_iff by auto
have "d(L) * z * y ≤ z * d(L) * y"
by (simp add: l2 mult_left_isotone)
also have "... ≤ z * (x ⊔ d(x * bot) * top)"
by (metis assms apx_def mult_assoc mult_right_isotone)
also have "... = z * x ⊔ z * d(x * bot) * top"
by (simp add: mult_left_dist_sup mult_assoc)
also have "... ≤ z * x ⊔ d(z * x * bot) * top"
by (metis sup_right_isotone mult_assoc mult_domain_top)
finally show ?thesis
using 1 by (simp add: apx_def mult_assoc)
qed
subclass apx_semiring
apply unfold_locales
apply (metis sup_ge2 apx_def l3 mult_right_isotone order_trans top_greatest)
apply (simp add: sup_apx_left_isotone)
apply (simp add: mult_apx_left_isotone)
by (simp add: mult_apx_right_isotone)
lemma meet_L_apx_isotone:
"x ⊑ y ⟹ x ⊓ L ⊑ y ⊓ L"
by (smt (z3) inf.cobounded2 sup.coboundedI1 sup_absorb sup_commute apx_def apx_meet_L d_restrict_equals l20 inf_commute meet_domain)
definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"
definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ (ν f ⊓ L)"
definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu f ≡ d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top"
definition nu_below_mu_nu_2 :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu_2 f ≡ d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"
definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_nu f ≡ μ f ⊔ (ν f ⊓ L) ⊑ ν f"
definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ (ν f ⊓ L)"
definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"
lemma mu_below_l:
"μ f ≤ μ f ⊔ (ν f ⊓ L)"
by simp
lemma l_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ (ν f ⊓ L) ≤ ν f"
by (simp add: mu_below_nu)
lemma n_l_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (μ f ⊔ (ν f ⊓ L)) ⊓ L = ν f ⊓ L"
by (meson l_below_nu inf.sup_same_context inf_le1 order_trans sup.cobounded2)
lemma l_apx_mu:
"μ f ⊔ (ν f ⊓ L) ⊑ μ f"
by (simp add: apx_def d_mult_below le_supI1 sup_inf_distrib1)
lemma nu_below_mu_nu_nu_below_mu_nu_2:
assumes "nu_below_mu_nu f"
shows "nu_below_mu_nu_2 f"
proof -
have "d(L) * ν f = d(L) * (d(L) * ν f)"
by (simp add: d_idempotent ils.il_inf_associative)
also have "... ≤ d(L) * (μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top)"
using assms mult_isotone nu_below_mu_nu_def by blast
also have "... = d(L) * (μ f ⊔ (ν f ⊓ L)) ⊔ d(L) * d(ν f * bot) * top"
by (simp add: ils.il_inf_associative mult_left_dist_sup)
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(L) * d(ν f * bot) * top"
using d_mult_below sup_left_isotone by auto
also have "... = μ f ⊔ (ν f ⊓ L) ⊔ d(d(ν f * bot) * L) * top"
by (simp add: d_commutative d_export)
also have "... = μ f ⊔ (ν f ⊓ L) ⊔ d((ν f ⊓ L) * bot) * top"
using l51 by auto
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"
by (meson d_isotone inf.eq_refl mult_isotone semiring.add_left_mono sup.cobounded2)
finally show ?thesis
using nu_below_mu_nu_2_def by auto
qed
lemma nu_below_mu_nu_2_nu_below_mu_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "nu_below_mu_nu_2 f"
shows "nu_below_mu_nu f"
proof -
have "d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"
using assms(3) nu_below_mu_nu_2_def by blast
also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top"
by (metis assms(1,2) d_isotone inf.sup_monoid.add_commute inf.sup_right_divisibility le_supI le_supI2 mu_below_nu mult_left_isotone sup_left_divisibility)
finally show ?thesis
by (simp add: nu_below_mu_nu_def)
qed
lemma nu_below_mu_nu_equivalent:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (nu_below_mu_nu f ⟷ nu_below_mu_nu_2 f)"
using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast
lemma nu_below_mu_nu_2_mu_nu_apx_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "nu_below_mu_nu_2 f"
shows "mu_nu_apx_nu f"
proof -
have "μ f ⊔ (ν f ⊓ L) ≤ ν f ⊔ L"
using assms(1,2) l_below_nu le_supI1 by blast
thus ?thesis
using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed
lemma mu_nu_apx_nu_mu_nu_apx_meet:
assumes "mu_nu_apx_nu f"
shows "mu_nu_apx_meet f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "is_apx_meet (μ f) (ν f) ?l"
apply (unfold is_apx_meet_def, intro conjI)
apply (simp add: l_apx_mu)
using assms mu_nu_apx_nu_def apply blast
by (metis apx_meet_L le_supI2 sup.order_iff sup_apx_left_isotone sup_inf_absorb)
thus ?thesis
by (smt apx_meet_char mu_nu_apx_meet_def)
qed
lemma mu_nu_apx_meet_apx_meet_below_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto
lemma apx_meet_below_nu_nu_below_mu_nu_2:
assumes "apx_meet_below_nu f"
shows "nu_below_mu_nu_2 f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
proof
fix m
show "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
proof
assume 1: "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f"
hence "m ≤ ?l"
by (metis apx_def ils.il_associative sup.orderE sup.orderI sup_inf_distrib1 sup_inf_distrib2)
hence "m ⊔ d(m * bot) * top ≤ ?l ⊔ d(?l * bot) * top"
by (meson d_isotone order.trans le_supI le_supI2 mult_left_isotone sup.cobounded1)
thus "d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
using 1 apx_def order_lesseq_imp by blast
qed
qed
thus ?thesis
by (smt (verit) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed
lemma has_apx_least_fixpoint_kappa_apx_meet:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "apx.has_least_fixpoint f"
shows "kappa_apx_meet f"
proof -
have 1: "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ d(L) * κ f ≤ w ⊔ d(w * bot) * top"
by (metis assms(2,3) apx_def mult_right_isotone order_trans kappa_below_nu)
have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ≤ κ f ⊔ L"
by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
hence "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
using 1 apx_def by blast
hence "is_apx_meet (μ f) (ν f) (κ f)"
using assms apx_meet_char is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu kappa_apx_meet_def by presburger
thus ?thesis
by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed
lemma kappa_apx_meet_apx_meet_below_nu:
"has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force
lemma apx_meet_below_nu_kappa_mu_nu:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "isotone f"
and "apx.isotone f"
and "apx_meet_below_nu f"
shows "kappa_mu_nu f"
proof -
let ?l = "μ f ⊔ (ν f ⊓ L)"
let ?m = "μ f △ ν f"
have 1: "?m = ?l"
by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
have 2: "?l ≤ f(?l) ⊔ L"
proof -
have "?l ≤ μ f ⊔ L"
using sup_right_isotone by auto
also have "... = f(μ f) ⊔ L"
by (simp add: assms(1) mu_unfold)
also have "... ≤ f(?l) ⊔ L"
by (metis assms(3) sup_left_isotone sup_ge1 isotone_def)
finally show ?thesis
.
qed
have "d(L) * f(?l) ≤ ?l ⊔ d(?l * bot) * top"
proof -
have "d(L) * f(?l) ≤ d(L) * f(ν f)"
by (metis assms(1-3) l_below_nu mult_right_isotone ord.isotone_def)
also have "... = d(L) * ν f"
by (metis assms(2) nu_unfold)
also have "... ≤ ?l ⊔ d(?l * bot) * top"
using apx_meet_below_nu_nu_below_mu_nu_2 assms(5) nu_below_mu_nu_2_def by blast
finally show ?thesis
.
qed
hence 3: "?l ⊑ f(?l)"
using 2 by (simp add: apx_def)
have 4: "f(?l) ⊑ μ f"
proof -
have "?l ⊑ μ f"
by (simp add: l_apx_mu)
thus ?thesis
by (metis assms(1,4) mu_unfold ord.isotone_def)
qed
have 5: "f(?l) ⊑ ν f"
proof -
have "?l ⊑ ν f"
by (meson apx_meet_below_nu_nu_below_mu_nu_2 assms(1,2,5) l_below_nu apx_def le_supI1 nu_below_mu_nu_2_def)
thus ?thesis
by (metis assms(2,4) nu_unfold ord.isotone_def)
qed
hence "f(?l) ⊑ ?l"
using 1 4 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
hence 6: "f(?l) = ?l"
using 3 apx.order.antisym by blast
have "∀y . f(y) = y ⟶ ?l ⊑ y"
proof
fix y
show "f(y) = y ⟶ ?l ⊑ y"
proof
assume 7: "f(y) = y"
hence 8: "?l ≤ y ⊔ L"
using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
have "y ≤ ν f"
using 7 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
hence "d(L) * y ≤ ?l ⊔ d(?l * bot) * top"
using 3 5 by (smt (z3) apx.order.trans apx_def semiring.distrib_left sup.absorb_iff2 sup_assoc)
thus "?l ⊑ y"
using 8 by (simp add: apx_def)
qed
qed
thus ?thesis
using 1 6 by (smt (verit) kappa_mu_nu_def apx.is_least_fixpoint_def apx.least_fixpoint_char)
qed
lemma kappa_mu_nu_has_apx_least_fixpoint:
"kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
by (simp add: kappa_mu_nu_def)
lemma nu_below_mu_nu_kappa_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast
lemma kappa_mu_nu_nu_below_mu_nu:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def nu_below_mu_nu_2_nu_below_mu_nu)
definition kappa_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "kappa_mu_nu_L f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ d(ν f * bot) * L"
definition nu_below_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "nu_below_mu_nu_L f ≡ d(L) * ν f ≤ μ f ⊔ d(ν f * bot) * top"
definition mu_nu_apx_nu_L :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_nu_L f ≡ μ f ⊔ d(ν f * bot) * L ⊑ ν f"
definition mu_nu_apx_meet_L :: "('a ⇒ 'a) ⇒ bool"
where "mu_nu_apx_meet_L f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ d(ν f * bot) * L"
lemma n_below_l:
"x ⊔ d(y * bot) * L ≤ x ⊔ (y ⊓ L)"
using d_mult_below l13 sup_right_isotone by auto
lemma n_equal_l:
assumes "nu_below_mu_nu_L f"
shows"μ f ⊔ d(ν f * bot) * L = μ f ⊔ (ν f ⊓ L)"
proof -
have "ν f ⊓ L ≤ (μ f ⊔ d(ν f * bot) * top) ⊓ L"
using assms l31 nu_below_mu_nu_L_def by force
also have "... ≤ μ f ⊔ d(ν f * bot) * L"
using distrib(4) inf.sup_monoid.add_commute meet_domain_top sup_left_isotone by force
finally have "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ d(ν f * bot) * L"
by auto
thus ?thesis
by (meson order.antisym n_below_l)
qed
lemma nu_below_mu_nu_L_nu_below_mu_nu:
"nu_below_mu_nu_L f ⟹ nu_below_mu_nu f"
using order_lesseq_imp sup.cobounded1 sup_left_isotone nu_below_mu_nu_L_def nu_below_mu_nu_def by blast
lemma nu_below_mu_nu_L_kappa_mu_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu_L f ⟹ kappa_mu_nu_L f"
using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by auto
lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto
lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_meet_L f"
using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto
lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
assumes "has_least_fixpoint f"
and "has_greatest_fixpoint f"
and "mu_nu_apx_nu_L f"
shows "nu_below_mu_nu_L f"
proof -
let ?n = "μ f ⊔ d(ν f * bot) * L"
let ?l = "μ f ⊔ (ν f ⊓ L)"
have "d(L) * ν f ≤ ?n ⊔ d(?n * bot) * top"
using assms(3) apx_def mu_nu_apx_nu_L_def by blast
also have "... ≤ ?n ⊔ d(?l * bot) * top"
using d_isotone mult_left_isotone semiring.add_left_mono n_below_l by auto
also have "... ≤ ?n ⊔ d(ν f * bot) * top"
by (meson assms(1,2) l_below_nu d_isotone mult_left_isotone sup_right_isotone)
finally show ?thesis
by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed
lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
"has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by force
lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
"mu_nu_apx_meet_L f ⟹ mu_nu_apx_nu_L f"
using apx_greatest_lower_bound mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce
lemma kappa_mu_nu_L_nu_below_mu_nu_L:
"has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ nu_below_mu_nu_L f"
using kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L by auto
end
class itering_apx = domain_itering_lattice_L + domain_semiring_lattice_apx
begin
lemma circ_apx_isotone:
assumes "x ⊑ y"
shows "x⇧∘ ⊑ y⇧∘"
proof -
have 1: "x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
using assms apx_def by auto
have "d(L) * y⇧∘ ≤ (d(L) * y)⇧∘"
by (metis d_circ_import d_mult_below l2)
also have "... ≤ x⇧∘ * (d(x * bot) * top * x⇧∘)⇧∘"
using 1 by (metis circ_sup_1 circ_isotone)
also have "... = x⇧∘ ⊔ x⇧∘ * d(x * bot) * top"
by (metis circ_left_top mult_assoc mult_left_dist_sup mult_1_right mult_top_circ)
also have "... ≤ x⇧∘ ⊔ d(x⇧∘ * x * bot) * top"
by (metis sup_right_isotone mult_assoc mult_domain_top)
finally have 2: "d(L) * y⇧∘ ≤ x⇧∘ ⊔ d(x⇧∘ * bot) * top"
using circ_plus_same d0_circ_left_unfold by auto
have "x⇧∘ ≤ y⇧∘ * L⇧∘"
using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone l40 le_iff_sup mult_assoc)
also have "... = y⇧∘ ⊔ y⇧∘ * L"
by (simp add: circ_L mult_left_dist_sup sup_commute)
also have "... ≤ y⇧∘ ⊔ y⇧∘ * bot ⊔ L"
using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
finally have "x⇧∘ ≤ y⇧∘ ⊔ L"
using sup.absorb_iff1 zero_right_mult_decreasing by auto
thus ?thesis
using 2 by (simp add: apx_def)
qed
end
class omega_algebra_apx = domain_omega_algebra_lattice_L + domain_semiring_lattice_apx
sublocale omega_algebra_apx < star: itering_apx where circ = star ..
context omega_algebra_apx
begin
lemma omega_apx_isotone:
assumes "x ⊑ y"
shows "x⇧ω ⊑ y⇧ω"
proof -
have 1: "x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
using assms apx_def by auto
have "d(L) * y⇧ω = (d(L) * y)⇧ω"
by (simp add: d_omega_export l2)
also have "... ≤ (x ⊔ d(x * bot) * top)⇧ω"
using 1 by (simp add: omega_isotone)
also have "... = (x⇧⋆ * d(x * bot) * top)⇧ω ⊔ (x⇧⋆ * d(x * bot) * top)⇧⋆ * x⇧ω"
by (simp add: ils.il_inf_associative omega_decompose)
also have "... ≤ x⇧⋆ * d(x * bot) * top ⊔ (x⇧⋆ * d(x * bot) * top)⇧⋆ * x⇧ω"
using mult_top_omega sup_left_isotone by blast
also have "... = x⇧⋆ * d(x * bot) * top ⊔ (1 ⊔ x⇧⋆ * d(x * bot) * top * (x⇧⋆ * d(x * bot) * top)⇧⋆) * x⇧ω"
by (simp add: star_left_unfold_equal)
also have "... ≤ x⇧ω ⊔ x⇧⋆ * d(x * bot) * top"
by (smt (verit, ccfv_threshold) sup_mono le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest)
also have "... ≤ x⇧ω ⊔ d(x⇧⋆ * x * bot) * top"
by (metis sup_right_isotone mult_assoc mult_domain_top)
also have "... ≤ x⇧ω ⊔ d(x⇧⋆ * bot) * top"
by (simp add: dL_star.d0_circ_left_unfold star_plus)
finally have 2: "d(L) * y⇧ω ≤ x⇧ω ⊔ d(x⇧ω * bot) * top"
by (meson sup_right_isotone d0_star_below_d0_omega mult_left_isotone order_trans)
have "x⇧ω ≤ (y ⊔ L)⇧ω"
using 1 by (simp add: omega_isotone)
also have "... = (y⇧⋆ * L)⇧ω ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
by (simp add: omega_decompose)
also have "... = y⇧⋆ * L * (y⇧⋆ * L)⇧ω ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
using omega_unfold by auto
also have "... ≤ y⇧⋆ * L ⊔ (y⇧⋆ * L)⇧⋆ * y⇧ω"
using mult_L_omega omega_unfold sup_left_isotone by auto
also have "... = y⇧⋆ * L ⊔ (1 ⊔ y⇧⋆ * L * (y⇧⋆ * L)⇧⋆) * y⇧ω"
by (simp add: star_left_unfold_equal)
also have "... ≤ y⇧⋆ * L ⊔ y⇧ω"
by (simp add: dL_star.mult_L_circ_mult_below star_left_unfold_equal sup_commute)
also have "... ≤ y⇧⋆ * bot ⊔ L ⊔ y⇧ω"
by (simp add: l14 le_supI1)
finally have "x⇧ω ≤ y⇧ω ⊔ L"
using star_bot_below_omega sup.left_commute sup.order_iff sup_commute by auto
thus ?thesis
using 2 by (simp add: apx_def)
qed
lemma combined_apx_isotone:
"x ⊑ y ⟹ (x⇧ω ⊓ L) ⊔ x⇧⋆ * z ⊑ (y⇧ω ⊓ L) ⊔ y⇧⋆ * z"
using meet_L_apx_isotone mult_apx_left_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone by auto
lemma d_split_nu_mu:
"d(L) * (y⇧ω ⊔ y⇧⋆ * z) ≤ y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L) ⊔ d((y⇧ω ⊔ y⇧⋆ * z) * bot) * top"
proof -
have "d(L) * y⇧ω ≤ (y⇧ω ⊓ L) ⊔ d(y⇧ω * bot) * top"
using l31 l91 omega_vector sup_right_isotone by auto
hence "d(L) * (y⇧ω ⊔ y⇧⋆ * z) ≤ y⇧⋆ * z ⊔ (y⇧ω ⊓ L) ⊔ d(y⇧ω * bot) * top"
by (smt sup_assoc sup_commute sup_mono d_mult_below mult_left_dist_sup)
also have "... ≤ y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L) ⊔ d(y⇧ω * bot) * top"
by (simp add: le_supI1 le_supI2)
also have "... ≤ y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L) ⊔ d((y⇧ω ⊔ y⇧⋆ * z) * bot) * top"
by (meson d_isotone mult_left_isotone sup.cobounded1 sup_right_isotone)
finally show ?thesis
.
qed
lemma loop_exists:
"d(L) * ν (λx . y * x ⊔ z) ≤ μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L) ⊔ d(ν (λx . y * x ⊔ z) * bot) * top"
by (simp add: d_split_nu_mu omega_loop_nu star_loop_mu)
lemma loop_apx_least_fixpoint:
"apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L))"
using apx.least_fixpoint_char affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu kappa_mu_nu_def by auto
lemma loop_has_apx_least_fixpoint:
"apx.has_least_fixpoint (λx . y * x ⊔ z)"
by (metis apx.has_least_fixpoint_def loop_apx_least_fixpoint)
lemma loop_semantics:
"κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L)"
using apx.least_fixpoint_char loop_apx_least_fixpoint by auto
lemma loop_semantics_kappa_mu_nu:
"κ (λx . y * x ⊔ z) = (y⇧ω ⊓ L) ⊔ y⇧⋆ * z"
proof -
have "κ (λx . y * x ⊔ z) = y⇧⋆ * z ⊔ ((y⇧ω ⊔ y⇧⋆ * z) ⊓ L)"
by (metis loop_semantics omega_loop_nu star_loop_mu)
thus ?thesis
by (metis sup.absorb2 sup_commute sup_ge2 sup_inf_distrib1)
qed
lemma loop_semantics_kappa_mu_nu_domain:
"κ (λx . y * x ⊔ z) = d(y⇧ω) * L ⊔ y⇧⋆ * z"
by (simp add: omega_meet_L loop_semantics_kappa_mu_nu)
lemma loop_semantics_apx_isotone:
"w ⊑ y ⟹ κ (λx . w * x ⊔ z) ⊑ κ (λx . y * x ⊔ z)"
by (metis loop_semantics_kappa_mu_nu combined_apx_isotone)
end
end
Theory Extended_Designs
section ‹Extended Designs›
theory Extended_Designs
imports Omega_Algebras Domain
begin
class domain_semiring_L_below = left_zero_domain_semiring + L +
assumes L_left_zero_below: "L * x ≤ L"
assumes mult_L_split: "x * L = x * bot ⊔ d(x) * L"
begin
lemma d_zero_mult_L:
"d(x * bot) * L ≤ x"
by (metis le_sup_iff mult_L_split mult_assoc mult_left_zero zero_right_mult_decreasing)
lemma mult_L:
"x * L ≤ x * bot ⊔ L"
by (metis sup_right_isotone d_mult_below mult_L_split)
lemma d_mult_L:
"d(x) * L ≤ x * L"
by (metis sup_right_divisibility mult_L_split)
lemma d_L_split:
"x * d(y) * L = x * bot ⊔ d(x * y) * L"
by (metis d_commutative d_mult_d d_zero mult_L_split mult_assoc mult_left_zero)
lemma d_mult_mult_L:
"d(x * y) * L ≤ x * d(y) * L"
using d_L_split by auto
lemma L_L:
"L * L = L"
by (metis d_restrict_equals le_iff_sup mult_L_split zero_right_mult_decreasing)
end
class antidomain_semiring_L = left_zero_antidomain_semiring + L +
assumes d_zero_mult_L: "d(x * bot) * L ≤ x"
assumes d_L_zero : "d(L * bot) = 1"
assumes mult_L : "x * L ≤ x * bot ⊔ L"
begin
lemma L_left_zero:
"L * x = L"
by (metis order.antisym d_L_zero d_zero_mult_L mult_assoc mult_left_one mult_left_zero zero_right_mult_decreasing)
subclass domain_semiring_L_below
apply unfold_locales
apply (simp add: L_left_zero)
apply (rule order.antisym)
apply (smt d_restrict_equals le_iff_sup mult_L mult_assoc mult_left_dist_sup)
by (metis le_sup_iff d_L_zero d_mult_d d_zero_mult_L mult_assoc mult_right_isotone mult_1_right bot_least)
end
class ed_below = bounded_left_zero_omega_algebra + domain_semiring_L_below + Omega +
assumes Omega_def: "x⇧Ω = d(x⇧ω) * L ⊔ x⇧⋆"
begin
lemma Omega_isotone:
"x ≤ y ⟹ x⇧Ω ≤ y⇧Ω"
by (metis Omega_def sup_mono d_isotone mult_left_isotone omega_isotone star.circ_isotone)
lemma star_below_Omega:
"x⇧⋆ ≤ x⇧Ω"
using Omega_def by auto
lemma one_below_Omega:
"1 ≤ x⇧Ω"
using order_trans star.circ_reflexive star_below_Omega by blast
lemma L_left_zero_star:
"L * x⇧⋆ = L"
by (meson L_left_zero_below order.antisym star.circ_back_loop_prefixpoint sup.boundedE)
lemma L_left_zero_Omega:
"L * x⇧Ω = L"
using L_left_zero_star L_left_zero_below Omega_def mult_left_dist_sup sup.order_iff sup_monoid.add_commute by auto
lemma mult_L_star:
"(x * L)⇧⋆ = 1 ⊔ x * L"
by (metis L_left_zero_star mult_assoc star.circ_left_unfold)
lemma mult_L_omega_below:
"(x * L)⇧ω ≤ x * L"
by (metis L_left_zero_below mult_right_isotone omega_slide)
lemma mult_L_sup_star:
"(x * L ⊔ y)⇧⋆ = y⇧⋆ ⊔ y⇧⋆ * x * L"
by (metis L_left_zero_star sup_commute mult_assoc star.circ_unfold_sum)
lemma mult_L_sup_omega_below:
"(x * L ⊔ y)⇧ω ≤ y⇧ω ⊔ y⇧⋆ * x * L"
proof -
have "(x * L ⊔ y)⇧ω = (y⇧⋆ * x * L)⇧ω ⊔ (y⇧⋆ * x * L)⇧⋆ * y⇧ω"
by (simp add: ils.il_inf_associative omega_decompose sup_commute)
also have "... ≤ y⇧⋆ * x * L ⊔ (y⇧⋆ * x * L)⇧⋆ * y⇧ω"
using sup_left_isotone mult_L_omega_below by auto
also have "... = y⇧⋆ * x * L ⊔ y⇧⋆ * x * L * y⇧ω ⊔ y⇧ω"
by (smt L_left_zero_star sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint)
also have "... ≤ y⇧ω ⊔ y⇧⋆ * x * L"
by (metis L_left_zero_star sup_commute eq_refl mult_assoc star.circ_back_loop_fixpoint)
finally show ?thesis
.
qed
lemma mult_L_sup_circ:
"(x * L ⊔ y)⇧Ω = d(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
proof -
have "(x * L ⊔ y)⇧Ω = d((x * L ⊔ y)⇧ω) * L ⊔ (x * L ⊔ y)⇧⋆"
by (simp add: Omega_def)
also have "... ≤ d(y⇧ω ⊔ y⇧⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧⋆"
by (metis sup_left_isotone d_isotone mult_L_sup_omega_below mult_left_isotone)
also have "... = d(y⇧ω) * L ⊔ d(y⇧⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧⋆"
by (simp add: d_dist_sup mult_right_dist_sup)
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * x * L * L ⊔ (x * L ⊔ y)⇧⋆"
by (meson d_mult_L order.refl sup.mono)
also have "... = d(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
by (smt L_L sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_assoc order_refl)
finally have 1: "(x * L ⊔ y)⇧Ω ≤ d(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L"
.
have 2: "d(y⇧ω) * L ≤ (x * L ⊔ y)⇧Ω"
using Omega_isotone Omega_def by force
have "y⇧⋆ ⊔ y⇧⋆ * x * L ≤ (x * L ⊔ y)⇧Ω"
by (metis Omega_def sup_ge2 mult_L_sup_star)
hence "d(y⇧ω) * L ⊔ y⇧⋆ ⊔ y⇧⋆ * x * L ≤ (x * L ⊔ y)⇧Ω"
using 2 by simp
thus ?thesis
using 1 by (simp add: order.antisym)
qed
lemma circ_sup_d:
"(x⇧Ω * y)⇧Ω * x⇧Ω = d((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L)"
proof -
have "(x⇧Ω * y)⇧Ω * x⇧Ω = ((d(x⇧ω) * L ⊔ x⇧⋆) * y)⇧Ω * x⇧Ω"
by (simp add: Omega_def)
also have "... = (d(x⇧ω) * L * y ⊔ x⇧⋆ * y)⇧Ω * x⇧Ω"
by (simp add: mult_right_dist_sup)
also have "... ≤ (d(x⇧ω) * L ⊔ x⇧⋆ * y)⇧Ω * x⇧Ω"
by (metis L_left_zero_below Omega_isotone sup_left_isotone mult_assoc mult_left_isotone mult_right_isotone)
also have "... = (d((x⇧⋆ * y)⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L) * x⇧Ω"
by (simp add: mult_L_sup_circ)
also have "... = d((x⇧⋆ * y)⇧ω) * L * x⇧Ω ⊔ (x⇧⋆ * y)⇧⋆ * x⇧Ω ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L * x⇧Ω"
using mult_right_dist_sup by auto
also have "... = d((x⇧⋆ * y)⇧ω) * L ⊔ (x⇧⋆ * y)⇧⋆ * x⇧Ω ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L"
by (simp add: L_left_zero_Omega mult.assoc)
also have "... = d((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L)"
by (simp add: Omega_def ils.il_inf_associative semiring.distrib_left sup_left_commute sup_monoid.add_commute)
finally have 1: "(x⇧Ω * y)⇧Ω * x⇧Ω ≤ d((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L)"
.
have "d((x⇧⋆ * y)⇧ω) * L ≤ (x⇧Ω * y)⇧Ω"
using Omega_isotone Omega_def mult_left_isotone by auto
also have "... ≤ (x⇧Ω * y)⇧Ω * x⇧Ω"
by (metis mult_right_isotone mult_1_right one_below_Omega)
finally have 2: "d((x⇧⋆ * y)⇧ω) * L ≤ (x⇧Ω * y)⇧Ω * x⇧Ω"
.
have 3: "(x⇧⋆ * y)⇧⋆ * x⇧⋆ ≤ (x⇧Ω * y)⇧Ω * x⇧Ω"
by (meson Omega_isotone order.trans mult_left_isotone mult_right_isotone star_below_Omega)
have "(x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L ≤ (x⇧⋆ * y)⇧⋆ * x⇧Ω"
by (metis Omega_def sup_commute mult_assoc mult_left_sub_dist_sup_right)
also have "... ≤ (x⇧Ω * y)⇧Ω * x⇧Ω"
using Omega_isotone Omega_def mult_left_isotone by force
finally have "d((x⇧⋆ * y)⇧ω) * L ⊔ ((x⇧⋆ * y)⇧⋆ * x⇧⋆ ⊔ (x⇧⋆ * y)⇧⋆ * d(x⇧ω) * L) ≤ (x⇧Ω * y)⇧Ω * x⇧Ω"
using 2 3 by (simp add: sup_assoc)
thus ?thesis
using 1 by (simp add: order.antisym)
qed
end
class ed = ed_below +
assumes L_left_zero: "L * x = L"
begin
lemma mult_L_omega:
"(x * L)⇧ω = x * L"
by (metis L_left_zero omega_slide)
lemma mult_L_sup_omega:
"(x * L ⊔ y)⇧ω = y⇧ω ⊔ y⇧⋆ * x * L"
by (metis L_left_zero ils.il_inf_associative mult_bot_add_omega sup_commute)
lemma d_Omega_circ_simulate_right_plus:
assumes "z * x ≤ y * y⇧Ω * z ⊔ w"
shows "z * x⇧Ω ≤ y⇧Ω * (z ⊔ w * x⇧Ω)"
proof -
have "z * x ≤ y * d(y⇧ω) * L * z ⊔ y * y⇧⋆ * z ⊔ w"
using assms Omega_def ils.il_inf_associative mult_right_dist_sup semiring.distrib_left by auto
also have "... ≤ y * d(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
by (metis L_left_zero_below sup_commute sup_right_isotone mult_assoc mult_right_isotone)
also have "... = y * bot ⊔ d(y * y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
by (simp add: d_L_split)
also have "... = d(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup omega_unfold)
finally have 1: "z * x ≤ d(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w"
.
have "(d(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆) * x = d(y⇧ω) * L * x ⊔ y⇧⋆ * z * x ⊔ y⇧⋆ * w * d(x⇧ω) * L * x ⊔ y⇧⋆ * w * x⇧⋆ * x"
using mult_right_dist_sup by fastforce
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z * x ⊔ y⇧⋆ * w * d(x⇧ω) * L * x ⊔ y⇧⋆ * w * x⇧⋆ * x"
by (metis L_left_zero_below sup_left_isotone mult_assoc mult_right_isotone)
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z * x ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆ * x"
by (metis L_left_zero_below sup_commute sup_left_isotone mult_assoc mult_right_isotone)
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z * x ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (meson star.circ_back_loop_prefixpoint sup.boundedE sup_right_isotone)
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * (d(y⇧ω) * L ⊔ y * y⇧⋆ * z ⊔ w) ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
using 1 by (smt sup_left_isotone sup_right_isotone le_iff_sup mult_assoc mult_left_dist_sup)
also have "... = d(y⇧ω) * L ⊔ y⇧⋆ * y * y⇧⋆ * z ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup d_L_split star.circ_back_loop_fixpoint star_mult_omega)
also have "... ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
using mult_isotone order_refl semiring.add_right_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_right_isotone by auto
finally have 2: "z * x⇧⋆ ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (smt le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
have "z * x * x⇧ω ≤ y * y⇧⋆ * z * x⇧ω ⊔ d(y⇧ω) * L * x⇧ω ⊔ w * x⇧ω"
using 1 by (metis sup_commute mult_left_isotone mult_right_dist_sup)
also have "... ≤ y * y⇧⋆ * z * x⇧ω ⊔ d(y⇧ω) * L ⊔ w * x⇧ω"
by (metis L_left_zero eq_refl ils.il_inf_associative)
finally have "z * x⇧ω ≤ y⇧ω ⊔ y⇧⋆ * d(y⇧ω) * L ⊔ y⇧⋆ * w * x⇧ω"
by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup omega_induct omega_unfold star.left_plus_circ)
hence "z * x⇧ω ≤ y⇧ω ⊔ y⇧⋆ * w * x⇧ω"
by (metis sup_commute d_mult_L le_iff_sup mult_assoc mult_right_isotone omega_sub_vector order_trans star_mult_omega)
hence "d(z * x⇧ω) * L ≤ d(y⇧ω) * L ⊔ y⇧⋆ * w * d(x⇧ω) * L"
by (smt sup_assoc sup_commute d_L_split d_dist_sup le_iff_sup mult_right_dist_sup)
hence "z * d(x⇧ω) * L ≤ z * bot ⊔ d(y⇧ω) * L ⊔ y⇧⋆ * w * d(x⇧ω) * L"
using d_L_split sup_assoc sup_right_isotone by force
also have "... ≤ y⇧⋆ * z ⊔ d(y⇧ω) * L ⊔ y⇧⋆ * w * d(x⇧ω) * L"
by (smt sup_commute sup_left_isotone sup_ge1 order_trans star.circ_loop_fixpoint zero_right_mult_decreasing)
finally have "z * d(x⇧ω) * L ≤ d(y⇧ω) * L ⊔ y⇧⋆ * z ⊔ y⇧⋆ * w * d(x⇧ω) * L ⊔ y⇧⋆ * w * x⇧⋆"
by (simp add: le_supI2 sup_commute)
thus ?thesis
using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed
lemma d_Omega_circ_simulate_left_plus:
assumes "x * z ≤ z * y⇧Ω ⊔ w"
shows "x⇧Ω * z ≤ (z ⊔ x⇧Ω * w) * y⇧Ω"
proof -
have "x * (z * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆) = x * z * d(y⇧ω) * L ⊔ x * z * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x * x⇧⋆ * w * d(y⇧ω) * L ⊔ x * x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup d_L_split omega_unfold)
also have "... ≤ (z * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w) * d(y⇧ω) * L ⊔ (z * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w) * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
also have "... = z * d(y⇧ω) * L ⊔ z * y⇧⋆ * d(y⇧ω) * L ⊔ w * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
also have "... = z * d(y⇧ω) * L ⊔ w * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ w * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc d_L_split star_mult_omega zero_right_mult_decreasing)
finally have "x * (z * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆) ≤ z * d(y⇧ω) * L ⊔ z * y⇧⋆ ⊔ d(x⇧ω) * L ⊔ x⇧⋆ * w * d(y⇧ω) * L ⊔ x⇧⋆ * w * y⇧⋆"
by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
thus ?thesis
by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed
end
text ‹Theorem 2.5 and Theorem 50.4›
sublocale ed < ed_omega: itering where circ = Omega
apply unfold_locales
apply (smt sup_assoc sup_commute sup_bot_left circ_sup_d Omega_def mult_left_dist_sup mult_right_dist_sup d_L_split d_dist_sup omega_decompose star.circ_sup_1 star.circ_slide)
apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup d_L_split omega_slide star.circ_mult)
using d_Omega_circ_simulate_right_plus apply blast
by (simp add: d_Omega_circ_simulate_left_plus)
sublocale ed < ed_star: itering where circ = star ..
class ed_2 = ed_below + antidomain_semiring_L + Omega
begin
subclass ed
apply unfold_locales
by (rule L_left_zero)
end
end
Theory Relative_Domain
section ‹Relative Domain›
theory Relative_Domain
imports Tests
begin
class Z =
fixes Z :: "'a"
class relative_domain_semiring = idempotent_left_semiring + dom + Z +
assumes d_restrict : "x ≤ d(x) * x ⊔ Z"
assumes d_mult_d : "d(x * y) = d(x * d(y))"
assumes d_below_one: "d(x) ≤ 1"
assumes d_Z : "d(Z) = bot"
assumes d_dist_sup : "d(x ⊔ y) = d(x) ⊔ d(y)"
assumes d_export : "d(d(x) * y) = d(x) * d(y)"
begin
lemma d_plus_one:
"d(x) ⊔ 1 = 1"
by (simp add: d_below_one sup_absorb2)
text ‹Theorem 44.2›
lemma d_zero:
"d(bot) = bot"
by (metis d_Z d_export mult_left_zero)
text ‹Theorem 44.3›
lemma d_involutive:
"d(d(x)) = d(x)"
by (metis d_mult_d mult_left_one)
lemma d_fixpoint:
"(∃y . x = d(y)) ⟷ x = d(x)"
using d_involutive by auto
lemma d_type:
"∀P . (∀x . x = d(x) ⟶ P(x)) ⟷ (∀x . P(d(x)))"
by (metis d_involutive)
text ‹Theorem 44.4›
lemma d_mult_sub:
"d(x * y) ≤ d(x)"
by (smt (verit, ccfv_threshold) d_plus_one d_dist_sup d_mult_d le_iff_sup mult.right_neutral mult_left_sub_dist_sup_right sup_commute)
lemma d_sub_one:
"x ≤ 1 ⟹ x ≤ d(x) ⊔ Z"
by (metis sup_left_isotone d_restrict mult_right_isotone mult_1_right order_trans)
lemma d_one:
"d(1) ⊔ Z = 1 ⊔ Z"
by (meson d_sub_one d_below_one order.trans preorder_one_closed sup.cobounded1 sup_same_context)
text ‹Theorem 44.8›
lemma d_strict:
"d(x) = bot ⟷ x ≤ Z"
by (metis sup_commute sup_bot_right d_Z d_dist_sup d_restrict le_iff_sup mult_left_zero)
text ‹Theorem 44.1›
lemma d_isotone:
"x ≤ y ⟹ d(x) ≤ d(y)"
using d_dist_sup sup_right_divisibility by force
lemma d_plus_left_upper_bound:
"d(x) ≤ d(x ⊔ y)"
by (simp add: d_isotone)
lemma d_idempotent:
"d(x) * d(x) = d(x)"
by (smt (verit, ccfv_threshold) d_involutive d_mult_sub d_Z d_dist_sup d_export d_restrict le_iff_sup sup_bot_left sup_commute)
text ‹Theorem 44.12›
lemma d_least_left_preserver:
"x ≤ d(y) * x ⊔ Z ⟷ d(x) ≤ d(y)"
apply (rule iffI)
apply (smt (z3) comm_monoid.comm_neutral d_involutive d_mult_sub d_plus_left_upper_bound d_Z d_dist_sup order_trans sup_absorb2 sup_bot.comm_monoid_axioms)
by (smt (verit, del_insts) d_restrict mult_right_dist_sup sup.cobounded1 sup.orderE sup_assoc sup_commute)
text ‹Theorem 44.9›
lemma d_weak_locality:
"x * y ≤ Z ⟷ x * d(y) ≤ Z"
by (metis d_mult_d d_strict)
lemma d_sup_closed:
"d(d(x) ⊔ d(y)) = d(x) ⊔ d(y)"
by (simp add: d_involutive d_dist_sup)
lemma d_mult_closed:
"d(d(x) * d(y)) = d(x) * d(y)"
using d_export d_mult_d by auto
lemma d_mult_left_lower_bound:
"d(x) * d(y) ≤ d(x)"
by (metis d_export d_involutive d_mult_sub)
lemma d_mult_left_absorb_sup:
"d(x) * (d(x) ⊔ d(y)) = d(x)"
by (smt d_sup_closed d_export d_idempotent d_involutive d_mult_sub order.eq_iff mult_left_sub_dist_sup_left)
lemma d_sup_left_absorb_mult:
"d(x) ⊔ d(x) * d(y) = d(x)"
using d_mult_left_lower_bound sup.absorb_iff1 by auto
lemma d_commutative:
"d(x) * d(y) = d(y) * d(x)"
by (metis sup_commute order.antisym d_sup_left_absorb_mult d_below_one d_export d_mult_left_absorb_sup mult_assoc mult_left_isotone mult_left_one)
lemma d_mult_greatest_lower_bound:
"d(x) ≤ d(y) * d(z) ⟷ d(x) ≤ d(y) ∧ d(x) ≤ d(z)"
by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)
lemma d_sup_left_dist_mult:
"d(x) ⊔ d(y) * d(z) = (d(x) ⊔ d(y)) * (d(x) ⊔ d(z))"
by (metis sup_assoc d_commutative d_dist_sup d_idempotent d_mult_left_absorb_sup mult_right_dist_sup)
lemma d_order:
"d(x) ≤ d(y) ⟷ d(x) = d(x) * d(y)"
by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)
text ‹Theorem 44.6›
lemma Z_mult_decreasing:
"Z * x ≤ Z"
by (metis d_mult_sub bot.extremum d_strict order.eq_iff)
text ‹Theorem 44.5›
lemma d_below_d_one:
"d(x) ≤ d(1)"
by (metis d_mult_sub mult_left_one)
text ‹Theorem 44.7›
lemma d_relative_Z:
"d(x) * x ⊔ Z = x ⊔ Z"
by (metis sup_ge1 sup_same_context d_below_one d_restrict mult_isotone mult_left_one)
lemma Z_left_zero_above_one:
"1 ≤ x ⟹ Z * x = Z"
by (metis Z_mult_decreasing order.eq_iff mult_right_isotone mult_1_right)
text ‹Theorem 44.11›
lemma kat_4:
"d(x) * y = d(x) * y * d(z) ⟹ d(x) * y ≤ y * d(z)"
by (metis d_below_one mult_left_isotone mult_left_one)
lemma kat_4_equiv:
"d(x) * y = d(x) * y * d(z) ⟷ d(x) * y ≤ y * d(z)"
apply (rule iffI)
apply (simp add: kat_4)
apply (rule order.antisym)
apply (metis d_idempotent mult_assoc mult_right_isotone)
by (metis d_below_one mult_right_isotone mult_1_right)
lemma kat_4_equiv_opp:
"y * d(x) = d(z) * y * d(x) ⟷ y * d(x) ≤ d(z) * y"
apply (rule iffI)
using d_below_one mult_right_isotone apply fastforce
apply (rule order.antisym)
apply (metis d_idempotent mult_assoc mult_left_isotone)
by (metis d_below_one mult_left_isotone mult_left_one)
text ‹Theorem 44.10›
lemma d_restrict_iff_1:
"d(x) * y ≤ z ⟷ d(x) * y ≤ d(x) * z"
by (smt (verit, del_insts) d_below_one d_idempotent mult_assoc mult_left_isotone mult_left_one mult_right_isotone order_trans)
end
typedef (overloaded) 'a dImage = "{ x::'a::relative_domain_semiring . (∃y::'a . x = d(y)) }"
by auto
lemma simp_dImage[simp]:
"∃y . Rep_dImage x = d(y)"
using Rep_dImage by simp
setup_lifting type_definition_dImage
text ‹Theorem 44›
instantiation dImage :: (relative_domain_semiring) bounded_distrib_lattice
begin
lift_definition sup_dImage :: "'a dImage ⇒ 'a dImage ⇒ 'a dImage" is sup
by (metis d_dist_sup)
lift_definition inf_dImage :: "'a dImage ⇒ 'a dImage ⇒ 'a dImage" is times
by (metis d_export)
lift_definition bot_dImage :: "'a dImage" is bot
by (metis d_zero)
lift_definition top_dImage :: "'a dImage" is "d(1)"
by auto
lift_definition less_eq_dImage :: "'a dImage ⇒ 'a dImage ⇒ bool" is less_eq .
lift_definition less_dImage :: "'a dImage ⇒ 'a dImage ⇒ bool" is less .
instance
apply intro_classes
apply (simp add: less_dImage.rep_eq less_eq_dImage.rep_eq less_le_not_le)
apply (simp add: less_eq_dImage.rep_eq)
using less_eq_dImage.rep_eq apply simp
apply (simp add: Rep_dImage_inject less_eq_dImage.rep_eq)
apply (metis (mono_tags) d_involutive d_mult_sub inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq order_refl simp_dImage)
apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
apply (simp add: bot_dImage.rep_eq less_eq_dImage.rep_eq)
apply (smt (z3) d_below_d_one less_eq_dImage.rep_eq simp_dImage top_dImage.rep_eq)
by (smt (z3) inf_dImage.rep_eq sup_dImage.rep_eq simp_dImage Rep_dImage_inject d_sup_left_dist_mult)
end
class bounded_relative_domain_semiring = relative_domain_semiring + bounded_idempotent_left_semiring
begin
lemma Z_top:
"Z * top = Z"
by (simp add: Z_left_zero_above_one)
lemma d_restrict_top:
"x ≤ d(x) * top ⊔ Z"
by (metis sup_left_isotone d_restrict mult_right_isotone order_trans top_greatest)
end
class relative_domain_semiring_split = relative_domain_semiring +
assumes split_Z: "x * (y ⊔ Z) ≤ x * y ⊔ Z"
begin
lemma d_restrict_iff:
"(x ≤ y ⊔ Z) ⟷ (x ≤ d(x) * y ⊔ Z)"
proof -
have "x ≤ y ⊔ Z ⟶ x ≤ d(x) * (y ⊔ Z) ⊔ Z"
by (smt sup_left_isotone d_restrict le_iff_sup mult_left_sub_dist_sup_left order_trans)
hence "x ≤ y ⊔ Z ⟶ x ≤ d(x) * y ⊔ Z"
by (meson le_supI order_lesseq_imp split_Z sup.cobounded2)
thus ?thesis
by (meson d_restrict_iff_1 le_supI mult_left_sub_dist_sup_left order_lesseq_imp sup.cobounded2)
qed
end
class relative_antidomain_semiring = idempotent_left_semiring + dom + Z + uminus +
assumes a_restrict : "-x * x ≤ Z"
assumes a_mult_d : "-(x * y) = -(x * --y)"
assumes a_complement: "-x * --x = bot"
assumes a_Z : "-Z = 1"
assumes a_export : "-(--x * y) = -x ⊔ -y"
assumes a_dist_sup : "-(x ⊔ y) = -x * -y"
assumes d_def : "d(x) = --x"
begin
notation
uminus ("a")
text ‹Theorem 45.7›
lemma a_complement_one:
"--x ⊔ -x = 1"
by (metis a_Z a_complement a_export a_mult_d mult_left_one)
text ‹Theorem 45.5 and Theorem 45.6›
lemma a_d_closed:
"d(a(x)) = a(x)"
by (metis a_mult_d d_def mult_left_one)
lemma a_below_one:
"a(x) ≤ 1"
using a_complement_one sup_right_divisibility by auto
lemma a_export_a:
"a(a(x) * y) = d(x) ⊔ a(y)"
by (metis a_d_closed a_export d_def)
lemma a_sup_absorb:
"(x ⊔ a(y)) * a(a(y)) = x * a(a(y))"
by (simp add: a_complement mult_right_dist_sup)
text ‹Theorem 45.10›
lemma a_greatest_left_absorber:
"a(x) * y ≤ Z ⟷ a(x) ≤ a(y)"
apply (rule iffI)
apply (smt a_Z a_sup_absorb a_dist_sup a_export_a a_mult_d sup_commute d_def le_iff_sup mult_left_one)
by (meson a_restrict mult_isotone order.refl order_trans)
lemma a_plus_left_lower_bound:
"a(x ⊔ y) ≤ a(x)"
by (metis a_greatest_left_absorber a_restrict sup_commute mult_left_sub_dist_sup_right order_trans)
text ‹Theorem 45.2›
subclass relative_domain_semiring
apply unfold_locales
apply (smt (verit) a_Z a_complement_one a_restrict sup_commute sup_ge1 case_split_left d_def order_trans)
using a_mult_d d_def apply force
apply (simp add: a_below_one d_def)
apply (metis a_Z a_complement d_def mult_left_one)
apply (simp add: a_export_a a_dist_sup d_def)
using a_dist_sup a_export d_def by auto
text ‹Theorem 45.1›
subclass tests
apply unfold_locales
apply (simp add: mult_assoc)
apply (metis a_dist_sup sup_commute)
apply (smt a_complement a_d_closed a_export_a sup_bot_right d_sup_left_dist_mult)
apply (metis a_d_closed a_dist_sup d_def)
apply (rule the_equality[THEN sym])
apply (simp add: a_complement)
apply (simp add: a_complement)
using a_d_closed a_Z d_Z d_def apply force
using a_export a_mult_d apply fastforce
apply (metis a_d_closed d_order)
by (simp add: less_le_not_le)
lemma a_plus_mult_d:
"-(x * y) ⊔ -(x * --y) = -(x * --y)"
using a_mult_d by auto
lemma a_mult_d_2:
"a(x * y) = a(x * d(y))"
using a_mult_d d_def by auto
lemma a_3:
"a(x) * a(y) * d(x ⊔ y) = bot"
by (metis a_complement a_dist_sup d_def)
lemma a_fixpoint:
"∀x . (a(x) = x ⟶ (∀y . y = bot))"
by (metis a_complement_one mult_1_left mult_left_zero order.refl sup.order_iff tests_dual.one_def)
text ‹Theorem 45.9›
lemma a_strict:
"a(x) = 1 ⟷ x ≤ Z"
by (metis a_Z d_def d_strict order.refl tests_dual.sba_dual.double_negation)
lemma d_complement_zero:
"d(x) * a(x) = bot"
by (simp add: d_def tests_dual.sub_commutative)
lemma a_complement_zero:
"a(x) * d(x) = bot"
by (simp add: d_def)
lemma a_shunting_zero:
"a(x) * d(y) = bot ⟷ a(x) ≤ a(y)"
by (simp add: d_def tests_dual.sba_dual.less_eq_inf_bot)
lemma a_antitone:
"x ≤ y ⟹ a(y) ≤ a(x)"
using a_plus_left_lower_bound sup_commute sup_right_divisibility by fastforce
lemma a_mult_deMorgan:
"a(a(x) * a(y)) = d(x ⊔ y)"
by (simp add: a_dist_sup d_def)
lemma a_mult_deMorgan_1:
"a(a(x) * a(y)) = d(x) ⊔ d(y)"
by (simp add: a_mult_deMorgan d_dist_sup)
lemma a_mult_deMorgan_2:
"a(d(x) * d(y)) = a(x) ⊔ a(y)"
using a_export d_def by auto
lemma a_plus_deMorgan:
"a(a(x) ⊔ a(y)) = d(x) * d(y)"
by (simp add: a_dist_sup d_def)
lemma a_plus_deMorgan_1:
"a(d(x) ⊔ d(y)) = a(x) * a(y)"
by (simp add: a_dist_sup d_def)
text ‹Theorem 45.8›
lemma a_mult_left_upper_bound:
"a(x) ≤ a(x * y)"
using a_shunting_zero d_def d_mult_sub tests_dual.less_eq_sup_top by auto
text ‹Theorem 45.6›
lemma d_a_closed:
"a(d(x)) = a(x)"
by (simp add: d_def)
lemma a_export_d:
"a(d(x) * y) = a(x) ⊔ a(y)"
by (simp add: a_export d_def)
lemma a_7:
"d(x) * a(d(y) ⊔ d(z)) = d(x) * a(y) * a(z)"
by (simp add: a_plus_deMorgan_1 mult_assoc)
lemma d_a_shunting:
"d(x) * a(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ d(y)"
by (simp add: d_def tests_dual.sba_dual.shunting_right)
lemma d_d_shunting:
"d(x) * d(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ a(y)"
by (simp add: d_def tests_dual.sba_dual.shunting_right)
lemma d_cancellation_1:
"d(x) ≤ d(y) ⊔ (d(x) * a(y))"
by (smt (z3) a_d_closed d_a_shunting d_export eq_refl sup_commute)
lemma d_cancellation_2:
"(d(z) ⊔ d(y)) * a(y) ≤ d(z)"
by (metis d_a_shunting d_dist_sup eq_refl)
lemma a_sup_closed:
"d(a(x) ⊔ a(y)) = a(x) ⊔ a(y)"
using a_mult_deMorgan tests_dual.sub_inf_def by auto
lemma a_mult_closed:
"d(a(x) * a(y)) = a(x) * a(y)"
using d_def tests_dual.sub_sup_closed by auto
lemma d_a_shunting_zero:
"d(x) * a(y) = bot ⟷ d(x) ≤ d(y)"
using a_shunting_zero d_def by force
lemma d_d_shunting_zero:
"d(x) * d(y) = bot ⟷ d(x) ≤ a(y)"
using d_a_shunting_zero d_def by auto
lemma d_compl_intro:
"d(x) ⊔ d(y) = d(x) ⊔ a(x) * d(y)"
by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)
lemma a_compl_intro:
"a(x) ⊔ a(y) = a(x) ⊔ d(x) * a(y)"
by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)
lemma kat_2:
"y * a(z) ≤ a(x) * y ⟹ d(x) * y * a(z) = bot"
by (metis d_complement_zero order.eq_iff mult_assoc mult_left_zero mult_right_isotone bot_least)
text ‹Theorem 45.4›
lemma kat_2_equiv:
"y * a(z) ≤ a(x) * y ⟷ d(x) * y * a(z) = bot"
apply (rule iffI)
apply (simp add: kat_2)
by (smt (verit, best) a_Z a_below_one a_complement_one case_split_left d_def mult_assoc mult_right_isotone mult_1_right bot_least)
lemma kat_3_equiv_opp:
"a(z) * y * d(x) = bot ⟷ y * d(x) = d(z) * y * d(x)"
using kat_2_equiv d_def kat_4_equiv_opp by auto
text ‹Theorem 45.4›
lemma kat_3_equiv_opp_2:
"d(z) * y * a(x) = bot ⟷ y * a(x) = a(z) * y * a(x)"
by (metis a_d_closed kat_3_equiv_opp d_def)
lemma kat_equiv_6:
"d(x) * y * a(z) = d(x) * y * bot ⟷ d(x) * y * a(z) ≤ y * bot"
by (metis d_restrict_iff_1 order.eq_iff mult_left_sub_dist_sup_right tests_dual.sba_dual.sup_right_unit mult_assoc)
lemma d_one_one:
"d(1) = 1"
by (simp add: d_def)
lemma case_split_left_sup:
"-p * x ≤ y ∧ --p * x ≤ z ⟹ x ≤ y ⊔ z"
by (smt (z3) a_complement_one case_split_left order_lesseq_imp sup.cobounded2 sup_ge1)
lemma test_mult_left_sub_dist_shunt:
"-p * (--p * x ⊔ Z) ≤ Z"
by (simp add: a_greatest_left_absorber a_Z a_dist_sup a_export)
lemma test_mult_left_dist_shunt:
"-p * (--p * x ⊔ Z) = -p * Z"
by (smt (verit, ccfv_SIG) order.antisym mult_left_sub_dist_sup_right sup.orderE tests_dual.sba_dual.sup_idempotent mult_assoc test_mult_left_sub_dist_shunt tests_dual.sup_absorb)
end
typedef (overloaded) 'a aImage = "{ x::'a::relative_antidomain_semiring . (∃y::'a . x = a(y)) }"
by auto
lemma simp_aImage[simp]:
"∃y . Rep_aImage x = a(y)"
using Rep_aImage by simp
setup_lifting type_definition_aImage
text ‹Theorem 45.3›
instantiation aImage :: (relative_antidomain_semiring) boolean_algebra
begin
lift_definition sup_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is sup
using tests_dual.sba_dual.sba_dual.inf_closed by auto
lift_definition inf_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is times
using tests_dual.sba_dual.inf_closed by auto
lift_definition minus_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is "λx y . x * a(y)"
using tests_dual.sba_dual.inf_closed by blast
lift_definition uminus_aImage :: "'a aImage ⇒ 'a aImage" is a
by auto
lift_definition bot_aImage :: "'a aImage" is bot
by (metis tests_dual.sba_dual.sba_dual.complement_bot)
lift_definition top_aImage :: "'a aImage" is 1
using a_Z by auto
lift_definition less_eq_aImage :: "'a aImage ⇒ 'a aImage ⇒ bool" is less_eq .
lift_definition less_aImage :: "'a aImage ⇒ 'a aImage ⇒ bool" is less .
instance
apply intro_classes
apply (simp add: less_aImage.rep_eq less_eq_aImage.rep_eq less_le_not_le)
apply (simp add: less_eq_aImage.rep_eq)
using less_eq_aImage.rep_eq apply simp
apply (simp add: Rep_aImage_inject less_eq_aImage.rep_eq)
apply (metis (mono_tags) a_below_one inf_aImage.rep_eq less_eq_aImage.rep_eq mult.right_neutral mult_right_isotone simp_aImage)
apply (metis (mono_tags, lifting) less_eq_aImage.rep_eq a_d_closed a_export bot.extremum_unique inf_aImage.rep_eq kat_equiv_6 mult.assoc mult.left_neutral mult_left_isotone mult_left_zero simp_aImage sup.cobounded1 tests_dual.sba_dual.sba_dual.complement_top)
apply (smt (z3) less_eq_aImage.rep_eq inf_aImage.rep_eq mult_isotone simp_aImage tests_dual.sba_dual.inf_idempotent)
apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
using less_eq_aImage.rep_eq sup_aImage.rep_eq apply force
apply (simp add: less_eq_aImage.rep_eq bot_aImage.rep_eq)
apply (smt (z3) less_eq_aImage.rep_eq a_below_one simp_aImage top_aImage.rep_eq)
apply (metis (mono_tags, lifting) tests_dual.sba_dual.sba_dual.inf_left_dist_sup Rep_aImage_inject inf_aImage.rep_eq sup_aImage.rep_eq simp_aImage)
apply (smt (z3) inf_aImage.rep_eq uminus_aImage.rep_eq Rep_aImage_inject a_complement bot_aImage.rep_eq simp_aImage)
apply (smt (z3) top_aImage.rep_eq Rep_aImage_inject a_complement_one simp_aImage sup_aImage.rep_eq sup_commute uminus_aImage.rep_eq)
by (metis (mono_tags) inf_aImage.rep_eq Rep_aImage_inject minus_aImage.rep_eq uminus_aImage.rep_eq)
end
class bounded_relative_antidomain_semiring = relative_antidomain_semiring + bounded_idempotent_left_semiring
begin
subclass bounded_relative_domain_semiring ..
lemma a_top:
"a(top) = bot"
by (metis a_plus_left_lower_bound bot_unique sup_right_top tests_dual.sba_dual.complement_top)
lemma d_top:
"d(top) = 1"
using a_top d_def by auto
lemma shunting_top_1:
"-p * x ≤ y ⟹ x ≤ --p * top ⊔ y"
by (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)
lemma shunting_Z:
"-p * x ≤ Z ⟷ x ≤ --p * top ⊔ Z"
apply (rule iffI)
apply (simp add: shunting_top_1)
by (smt a_top a_Z a_antitone a_dist_sup a_export a_greatest_left_absorber sup_commute sup_bot_right mult_left_one)
end
class relative_left_zero_antidomain_semiring = relative_antidomain_semiring + idempotent_left_zero_semiring
begin
lemma kat_3:
"d(x) * y * a(z) = bot ⟹ d(x) * y = d(x) * y * d(z)"
by (metis d_def mult_1_right mult_left_dist_sup sup_monoid.add_0_left tests_dual.inf_complement)
lemma a_a_below:
"a(a(x)) * y ≤ y"
using d_def d_restrict_iff_1 by auto
lemma kat_equiv_5:
"d(x) * y ≤ y * d(z) ⟷ d(x) * y * a(z) = d(x) * y * bot"
proof
assume "d(x) * y ≤ y * d(z)"
thus "d(x) * y * a(z) = d(x) * y * bot"
by (metis d_complement_zero kat_4_equiv mult_assoc)
next
assume "d(x) * y * a(z) = d(x) * y * bot"
hence "a(a(x)) * y * a(z) ≤ y * a(a(z))"
by (simp add: a_a_below d_def mult_isotone)
thus "d(x) * y ≤ y * d(z)"
by (metis a_a_below a_complement_one case_split_right d_def mult_isotone order_refl)
qed
lemma case_split_right_sup:
"x * -p ≤ y ⟹ x * --p ≤ z ⟹ x ≤ y ⊔ z"
by (smt (verit, ccfv_SIG) a_complement_one order.trans mult_1_right mult_left_dist_sup sup_commute sup_right_isotone)
end
class bounded_relative_left_zero_antidomain_semiring = relative_left_zero_antidomain_semiring + bounded_idempotent_left_zero_semiring
begin
lemma shunting_top:
"-p * x ≤ y ⟷ x ≤ --p * top ⊔ y"
apply (rule iffI)
apply (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)
by (metis a_complement sup_bot_left sup_right_divisibility mult_assoc mult_left_dist_sup mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone order_trans tests_dual.inf_left_unit)
end
end
Theory Relative_Modal
section ‹Relative Modal Operators›
theory Relative_Modal
imports Relative_Domain
begin
class relative_diamond_semiring = relative_domain_semiring + diamond +
assumes diamond_def: "|x>y = d(x * y)"
begin
lemma diamond_x_1:
"|x>1 = d(x)"
by (simp add: diamond_def)
lemma diamond_x_d:
"|x>d(y) = d(x * y)"
using d_mult_d diamond_def by auto
lemma diamond_x_und:
"|x>d(y) = |x>y"
using diamond_x_d diamond_def by auto
lemma diamond_d_closed:
"|x>y = d( |x>y)"
by (simp add: d_involutive diamond_def)
text ‹Theorem 46.11›
lemma diamond_bot_y:
"|bot>y = bot"
by (simp add: d_zero diamond_def)
lemma diamond_1_y:
"|1>y = d(y)"
by (simp add: diamond_def)
text ‹Theorem 46.12›
lemma diamond_1_d:
"|1>d(y) = d(y)"
by (simp add: diamond_1_y diamond_x_und)
text ‹Theorem 46.10›
lemma diamond_d_y:
"|d(x)>y = d(x) * d(y)"
by (simp add: d_export diamond_def)
text ‹Theorem 46.11›
lemma diamond_d_bot:
"|d(x)>bot = bot"
by (metis diamond_bot_y diamond_d_y d_commutative d_zero)
text ‹Theorem 46.12›
lemma diamond_d_1:
"|d(x)>1 = d(x)"
by (simp add: diamond_x_1 d_involutive)
lemma diamond_d_d:
"|d(x)>d(y) = d(x) * d(y)"
by (simp add: diamond_d_y diamond_x_und)
text ‹Theorem 46.12›
lemma diamond_d_d_same:
"|d(x)>d(x) = d(x)"
by (simp add: diamond_d_d d_idempotent)
text ‹Theorem 46.2›
lemma diamond_left_dist_sup:
"|x ⊔ y>z = |x>z ⊔ |y>z"
by (simp add: d_dist_sup diamond_def mult_right_dist_sup)
text ‹Theorem 46.3›
lemma diamond_right_sub_dist_sup:
"|x>y ⊔ |x>z ≤ |x>(y ⊔ z)"
by (metis d_dist_sup diamond_def le_iff_sup mult_left_sub_dist_sup)
text ‹Theorem 46.4›
lemma diamond_associative:
"|x * y>z = |x>(y * z)"
by (simp add: diamond_def mult_assoc)
text ‹Theorem 46.4›
lemma diamond_left_mult:
"|x * y>z = |x>|y>z"
using diamond_x_und diamond_def mult_assoc by auto
lemma diamond_right_mult:
"|x>(y * z) = |x>|y>z"
using diamond_associative diamond_left_mult by auto
text ‹Theorem 46.6›
lemma diamond_d_export:
"|d(x) * y>z = d(x) * |y>z"
using diamond_d_y diamond_def mult_assoc by auto
lemma diamond_diamond_export:
"||x>y>z = |x>y * |z>1"
using diamond_d_y diamond_def by force
text ‹Theorem 46.1›
lemma diamond_left_isotone:
"x ≤ y ⟹ |x>z ≤ |y>z"
by (metis diamond_left_dist_sup le_iff_sup)
text ‹Theorem 46.1›
lemma diamond_right_isotone:
"y ≤ z ⟹ |x>y ≤ |x>z"
by (metis diamond_right_sub_dist_sup le_iff_sup le_sup_iff)
lemma diamond_isotone:
"w ≤ y ⟹ x ≤ z ⟹ |w>x ≤ |y>z"
by (meson diamond_left_isotone diamond_right_isotone order_trans)
lemma diamond_left_upper_bound:
"|x>y ≤ |x ⊔ z>y"
by (simp add: diamond_left_isotone)
lemma diamond_right_upper_bound:
"|x>y ≤ |x>(y ⊔ z)"
by (simp add: diamond_right_isotone)
lemma diamond_lower_bound_right:
"|x>(d(y) * d(z)) ≤ |x>d(y)"
by (simp add: diamond_right_isotone d_mult_left_lower_bound)
lemma diamond_lower_bound_left:
"|x>(d(y) * d(z)) ≤ |x>d(z)"
using diamond_lower_bound_right d_commutative by force
text ‹Theorem 46.5›
lemma diamond_right_sub_dist_mult:
"|x>(d(y) * d(z)) ≤ |x>d(y) * |x>d(z)"
using diamond_lower_bound_left diamond_lower_bound_right d_mult_greatest_lower_bound diamond_def by force
text ‹Theorem 46.13›
lemma diamond_demodalisation_1:
"d(x) * |y>z ≤ Z ⟷ d(x) * y * d(z) ≤ Z"
by (metis d_weak_locality diamond_def mult_assoc)
text ‹Theorem 46.14›
lemma diamond_demodalisation_3:
"|x>y ≤ d(z) ⟷ x * d(y) ≤ d(z) * x ⊔ Z"
apply (rule iffI)
apply (smt (verit) sup_commute sup_right_isotone d_below_one d_restrict diamond_def diamond_x_und mult_left_isotone mult_right_isotone mult_1_right order_trans)
by (smt sup_commute sup_bot_left d_Z d_commutative d_dist_sup d_involutive d_mult_sub d_plus_left_upper_bound diamond_d_y diamond_def diamond_x_und le_iff_sup order_trans)
text ‹Theorem 46.6›
lemma diamond_d_export_2:
"|d(x) * y>z = d(x) * |d(x) * y>z"
by (metis diamond_d_export diamond_left_mult d_idempotent)
text ‹Theorem 46.7›
lemma diamond_d_promote:
"|x * d(y)>z = |x * d(y)>(d(y) * z)"
by (metis d_idempotent diamond_def mult_assoc)
text ‹Theorem 46.8›
lemma diamond_d_import_iff:
"d(x) ≤ |y>z ⟷ d(x) ≤ |d(x) * y>z"
by (metis diamond_d_export diamond_d_y d_order diamond_def order.eq_iff)
text ‹Theorem 46.9›
lemma diamond_d_import_iff_2:
"d(x) * d(y) ≤ |z>w ⟷ d(x) * d(y) ≤ |d(y) * z>w"
apply (rule iffI)
apply (metis diamond_associative d_export d_mult_greatest_lower_bound diamond_def order.refl)
by (metis diamond_d_y d_mult_greatest_lower_bound diamond_def mult_assoc)
end
class relative_box_semiring = relative_diamond_semiring + relative_antidomain_semiring + box +
assumes box_def: "|x]y = a(x * a(y))"
begin
text ‹Theorem 47.1›
lemma box_diamond:
"|x]y = a( |x>a(y))"
by (simp add: box_def d_a_closed diamond_def)
text ‹Theorem 47.2›
lemma diamond_box:
"|x>y = a( |x]a(y))"
using box_def d_def d_mult_d diamond_def by auto
lemma box_x_bot:
"|x]bot = a(x)"
by (metis box_def mult_1_right one_def)
lemma box_x_1:
"|x]1 = a(x * bot)"
by (simp add: box_def)
lemma box_x_d:
"|x]d(y) = a(x * a(y))"
by (simp add: box_def d_a_closed)
lemma box_x_und:
"|x]d(y) = |x]y"
by (simp add: box_diamond d_a_closed)
lemma box_x_a:
"|x]a(y) = a(x * y)"
using a_mult_d box_def by auto
text ‹Theorem 47.15›
lemma box_bot_y:
"|bot]y = 1"
using box_def by auto
lemma box_1_y:
"|1]y = d(y)"
by (simp add: box_def d_def)
text ‹Theorem 47.16›
lemma box_1_d:
"|1]d(y) = d(y)"
by (simp add: box_1_y box_x_und)
lemma box_1_a:
"|1]a(y) = a(y)"
by (simp add: box_x_a)
lemma box_d_y:
"|d(x)]y = a(x) ⊔ d(y)"
using a_export_a box_def d_def by auto
lemma box_a_y:
"|a(x)]y = d(x) ⊔ d(y)"
by (simp add: a_mult_deMorgan_1 box_def)
text ‹Theorem 47.14›
lemma box_d_bot:
"|d(x)]bot = a(x)"
by (simp add: box_x_bot d_a_closed)
lemma box_a_bot:
"|a(x)]bot = d(x)"
by (simp add: box_x_bot d_def)
text ‹Theorem 47.15›
lemma box_d_1:
"|d(x)]1 = 1"
by (simp add: box_d_y d_one_one)
lemma box_a_1:
"|a(x)]1 = 1"
by (simp add: box_x_1)
text ‹Theorem 47.13›
lemma box_d_d:
"|d(x)]d(y) = a(x) ⊔ d(y)"
by (simp add: box_d_y box_x_und)
lemma box_a_d:
"|a(x)]d(y) = d(x) ⊔ d(y)"
by (simp add: box_a_y box_x_und)
lemma box_d_a:
"|d(x)]a(y) = a(x) ⊔ a(y)"
by (simp add: box_x_a a_export_d)
lemma box_a_a:
"|a(x)]a(y) = d(x) ⊔ a(y)"
by (simp add: box_a_y a_d_closed)
text ‹Theorem 47.15›
lemma box_d_d_same:
"|d(x)]d(x) = 1"
using box_x_d d_complement_zero by auto
lemma box_a_a_same:
"|a(x)]a(x) = 1"
by (simp add: box_def)
text ‹Theorem 47.16›
lemma box_d_below_box:
"d(x) ≤ |d(y)]d(x)"
by (simp add: box_d_d)
lemma box_d_closed:
"|x]y = d( |x]y)"
by (simp add: a_d_closed box_def)
lemma box_deMorgan_1:
"a( |x]y) = |x>a(y)"
by (simp add: diamond_box box_def)
lemma box_deMorgan_2:
"a( |x>y) = |x]a(y)"
using box_x_a d_a_closed diamond_def by auto
text ‹Theorem 47.5›
lemma box_left_dist_sup:
"|x ⊔ y]z = |x]z * |y]z"
by (simp add: a_dist_sup box_def mult_right_dist_sup)
lemma box_right_dist_sup:
"|x](y ⊔ z) = a(x * a(y) * a(z))"
by (simp add: a_dist_sup box_def mult_assoc)
lemma box_associative:
"|x * y]z = a(x * y * a(z))"
by (simp add: box_def)
text ‹Theorem 47.6›
lemma box_left_mult:
"|x * y]z = |x]|y]z"
using box_x_a box_def mult_assoc by force
lemma box_right_mult:
"|x](y * z) = a(x * a(y * z))"
by (simp add: box_def)
text ‹Theorem 47.7›
lemma box_right_submult_d_d:
"|x](d(y) * d(z)) ≤ |x]d(y) * |x]d(z)"
by (smt a_antitone a_dist_sup a_export_d box_diamond d_a_closed diamond_def mult_left_sub_dist_sup)
lemma box_right_submult_a_d:
"|x](a(y) * d(z)) ≤ |x]a(y) * |x]d(z)"
by (metis box_right_submult_d_d a_d_closed)
lemma box_right_submult_d_a:
"|x](d(y) * a(z)) ≤ |x]d(y) * |x]a(z)"
using box_right_submult_a_d box_x_a d_def tests_dual.sub_commutative by auto
lemma box_right_submult_a_a:
"|x](a(y) * a(z)) ≤ |x]a(y) * |x]a(z)"
by (metis box_right_submult_d_d a_d_closed)
text ‹Theorem 47.8›
lemma box_d_export:
"|d(x) * y]z = a(x) ⊔ |y]z"
by (simp add: a_export_d box_def mult_assoc)
lemma box_a_export:
"|a(x) * y]z = d(x) ⊔ |y]z"
using box_a_y box_d_closed box_left_mult by auto
text ‹Theorem 47.4›
lemma box_left_antitone:
"y ≤ x ⟹ |x]z ≤ |y]z"
by (metis a_antitone box_def mult_left_isotone)
text ‹Theorem 47.3›
lemma box_right_isotone:
"y ≤ z ⟹ |x]y ≤ |x]z"
by (metis a_antitone box_def mult_right_isotone)
lemma box_antitone_isotone:
"y ≤ w ⟹ x ≤ z ⟹ |w]x ≤ |y]z"
by (meson box_left_antitone box_right_isotone order_trans)
lemma diamond_1_a:
"|1>a(y) = a(y)"
by (simp add: d_def diamond_1_y)
lemma diamond_a_y:
"|a(x)>y = a(x) * d(y)"
by (metis a_d_closed diamond_d_y)
lemma diamond_a_bot:
"|a(x)>bot = bot"
by (simp add: diamond_a_y d_zero)
lemma diamond_a_1:
"|a(x)>1 = a(x)"
by (simp add: d_def diamond_x_1)
lemma diamond_a_d:
"|a(x)>d(y) = a(x) * d(y)"
by (simp add: diamond_a_y diamond_x_und)
lemma diamond_d_a:
"|d(x)>a(y) = d(x) * a(y)"
by (simp add: a_d_closed diamond_d_y)
lemma diamond_a_a:
"|a(x)>a(y) = a(x) * a(y)"
by (simp add: a_mult_closed diamond_def)
lemma diamond_a_a_same:
"|a(x)>a(x) = a(x)"
by (simp add: diamond_a_a)
lemma diamond_a_export:
"|a(x) * y>z = a(x) * |y>z"
using diamond_a_y diamond_associative diamond_def by auto
lemma a_box_a_a:
"a(p) * |a(p)]a(q) = a(p) * a(q)"
using box_a_a box_a_bot box_x_bot tests_dual.sup_complement_intro by auto
lemma box_left_lower_bound:
"|x ⊔ y]z ≤ |x]z"
by (simp add: box_left_antitone)
lemma box_right_upper_bound:
"|x]y ≤ |x](y ⊔ z)"
by (simp add: box_right_isotone)
lemma box_lower_bound_right:
"|x](d(y) * d(z)) ≤ |x]d(y)"
by (simp add: box_right_isotone d_mult_left_lower_bound)
lemma box_lower_bound_left:
"|x](d(y) * d(z)) ≤ |x]d(z)"
by (simp add: box_right_isotone d_restrict_iff_1)
text ‹Theorem 47.9›
lemma box_d_import:
"d(x) * |y]z = d(x) * |d(x) * y]z"
using a_box_a_a box_left_mult box_def d_def by force
text ‹Theorem 47.10›
lemma box_d_promote:
"|x * d(y)]z = |x * d(y)](d(y) * z)"
using a_box_a_a box_x_a box_def d_def mult_assoc by auto
text ‹Theorem 47.11›
lemma box_d_import_iff:
"d(x) ≤ |y]z ⟷ d(x) ≤ |d(x) * y]z"
using box_d_export box_def d_def tests_dual.shunting by auto
text ‹Theorem 47.12›
lemma box_d_import_iff_2:
"d(x) * d(y) ≤ |z]w ⟷ d(x) * d(y) ≤ |d(y) * z]w"
apply (rule iffI)
using box_d_export le_supI2 apply simp
by (metis box_d_import d_commutative d_restrict_iff_1)
text ‹Theorem 47.20›
lemma box_demodalisation_2:
"-p ≤ |y](-q) ⟷ -p * y * --q ≤ Z"
by (simp add: a_greatest_left_absorber box_def mult_assoc)
lemma box_right_sub_dist_sup:
"|x]d(y) ⊔ |x]d(z) ≤ |x](d(y) ⊔ d(z))"
by (simp add: box_right_isotone)
lemma box_diff_var:
"|x](d(y) ⊔ a(z)) * |x]d(z) ≤ |x]d(z)"
by (simp add: box_right_dist_sup box_x_d tests_dual.upper_bound_right)
text ‹Theorem 47.19›
lemma diamond_demodalisation_2:
"|x>y ≤ d(z) ⟷ a(z) * x * d(y) ≤ Z"
using a_antitone a_greatest_left_absorber a_mult_d d_def diamond_def mult_assoc by fastforce
text ‹Theorem 47.17›
lemma box_below_Z:
"( |x]y) * x * a(y) ≤ Z"
by (simp add: a_restrict box_def mult_assoc)
text ‹Theorem 47.18›
lemma box_partial_correctness:
"|x]1 = 1 ⟷ x * bot ≤ Z"
by (simp add: box_x_1 a_strict)
lemma diamond_split:
"|x>y = d(z) * |x>y ⊔ a(z) * |x>y"
by (metis d_def diamond_def sup_monoid.add_commute tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)
lemma box_import_shunting:
"-p * -q ≤ |x](-r) ⟷ -q ≤ |-p * x](-r)"
by (smt box_demodalisation_2 mult_assoc sub_comm sub_mult_closed)
end
class relative_left_zero_diamond_semiring = relative_diamond_semiring + relative_domain_semiring + idempotent_left_zero_semiring
begin
lemma diamond_right_dist_sup:
"|x>(y ⊔ z) = |x>y ⊔ |x>z"
by (simp add: d_dist_sup diamond_def mult_left_dist_sup)
end
class relative_left_zero_box_semiring = relative_box_semiring + relative_left_zero_antidomain_semiring
begin
subclass relative_left_zero_diamond_semiring ..
lemma box_right_mult_d_d:
"|x](d(y) * d(z)) = |x]d(y) * |x]d(z)"
using a_dist_sup box_d_a box_def d_def mult_left_dist_sup by auto
lemma box_right_mult_a_d:
"|x](a(y) * d(z)) = |x]a(y) * |x]d(z)"
by (metis box_right_mult_d_d a_d_closed)
lemma box_right_mult_d_a:
"|x](d(y) * a(z)) = |x]d(y) * |x]a(z)"
using box_right_mult_a_d box_def box_x_a d_def by auto
lemma box_right_mult_a_a:
"|x](a(y) * a(z)) = |x]a(y) * |x]a(z)"
using a_dist_sup box_def mult_left_dist_sup tests_dual.sub_sup_demorgan by force
lemma box_demodalisation_3:
assumes "d(x) ≤ |y]d(z)"
shows "d(x) * y ≤ y * d(z) ⊔ Z"
proof -
have "d(x) * y * a(z) ≤ Z"
using assms a_greatest_left_absorber box_x_d d_def mult_assoc by auto
thus ?thesis
by (simp add: a_a_below case_split_right_sup d_def sup_commute mult_assoc)
qed
lemma fbox_diff:
"|x](d(y) ⊔ a(z)) ≤ |x]y ⊔ a( |x]z)"
by (smt (z3) a_compl_intro a_dist_sup a_mult_d a_plus_left_lower_bound sup_commute box_def d_def mult_left_dist_sup tests_dual.sba_dual.shunting)
lemma diamond_diff_var:
"|x>d(y) ≤ |x>(d(y) * a(z)) ⊔ |x>d(z)"
by (metis d_cancellation_1 diamond_right_dist_sup diamond_right_isotone sup_commute)
lemma diamond_diff:
"|x>y * a( |x>z) ≤ |x>(d(y) * a(z))"
by (metis d_a_shunting d_involutive diamond_def diamond_diff_var diamond_x_und)
end
end
Theory Complete_Tests
section ‹Complete Tests›
theory Complete_Tests
imports Tests
begin
class complete_tests = tests + Sup + Inf +
assumes sup_test: "test_set A ⟶ Sup A = --Sup A"
assumes sup_upper: "test_set A ∧ x ∈ A ⟶ x ≤ Sup A"
assumes sup_least: "test_set A ∧ (∀x∈A . x ≤ -y) ⟶ Sup A ≤ -y"
begin
lemma Sup_isotone:
"test_set B ⟹ A ⊆ B ⟹ Sup A ≤ Sup B"
by (metis sup_least sup_test sup_upper test_set_closed subset_eq)
lemma mult_right_dist_sup:
assumes "test_set A"
shows "Sup A * -p = Sup { x * -p | x . x ∈ A }"
proof -
have 1: "test_set { x * -p | x . x ∈ A }"
by (simp add: assms mult_right_dist_test_set)
have 2: "Sup { x * -p | x . x ∈ A } ≤ Sup A * -p"
by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_sup_left_isotone sub_mult_closed sup_test sup_least sup_upper test_set_def)
have "∀x∈A . x ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
proof
fix x
assume 3: "x ∈ A"
hence "x * -p ⊔ --p ≤ Sup { x * -p | x . x ∈ A } ⊔ --p"
using 1 by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_inf_left_isotone sub_mult_closed sup_upper test_set_def sup_test)
thus "x ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
using 1 3 by (smt (z3) assms tests_dual.inf_closed sub_comm test_set_def sup_test sub_mult_closed tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_left_isotone tests_dual.inf_absorb tests_dual.inf_less_eq_cases_3)
qed
hence "Sup A ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
by (simp add: assms sup_least)
hence "Sup A * -p ≤ Sup { x * -p | x . x ∈ A }"
using 1 by (smt (z3) assms sup_test tests_dual.sba_dual.shunting tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.sub_sup_demorgan)
thus ?thesis
using 1 2 by (smt (z3) assms sup_test tests_dual.sba_dual.sub_sup_closed tests_dual.antisymmetric tests_dual.inf_demorgan tests_dual.inf_idempotent)
qed
lemma mult_left_dist_sup:
assumes "test_set A"
shows "-p * Sup A = Sup { -p * x | x . x ∈ A }"
proof -
have 1: "Sup A * -p = Sup { x * -p | x . x ∈ A }"
by (simp add: assms mult_right_dist_sup)
have 2: "-p * Sup A = Sup A * -p"
by (metis assms sub_comm sup_test)
have "{ -p * x | x . x ∈ A } = { x * -p | x . x ∈ A }"
by (metis assms test_set_def tests_dual.sub_commutative)
thus ?thesis
using 1 2 by simp
qed
definition Sum :: "(nat ⇒ 'a) ⇒ 'a"
where "Sum f ≡ Sup { f n | n::nat . True }"
lemma Sum_test:
"test_seq t ⟹ Sum t = --Sum t"
using Sum_def sup_test test_seq_test_set by auto
lemma Sum_upper:
"test_seq t ⟹ t x ≤ Sum t"
using Sum_def sup_upper test_seq_test_set by auto
lemma Sum_least:
"test_seq t ⟹ (∀n . t n ≤ -p) ⟹ Sum t ≤ -p"
using Sum_def sup_least test_seq_test_set by force
lemma mult_right_dist_Sum:
"test_seq t ⟹ (∀n . t n * -p ≤ -q) ⟹ Sum t * -p ≤ -q"
by (smt (verit, del_insts) CollectD Sum_def sup_least sup_test test_seq_test_set test_set_def tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_closed)
lemma mult_left_dist_Sum:
"test_seq t ⟹ (∀n . -p * t n ≤ -q) ⟹ -p * Sum t ≤ -q"
by (smt (verit, del_insts) Sum_def mem_Collect_eq mult_left_dist_sup sub_mult_closed sup_least test_seq_test_set test_set_def)
lemma pSum_below_Sum:
"test_seq t ⟹ pSum t m ≤ Sum t"
using Sum_test Sum_upper nat_test_def pSum_below_sum test_seq_def mult_right_dist_Sum by auto
lemma pSum_sup:
assumes "test_seq t"
shows "pSum t m = Sup { t i | i . i ∈ {..<m} }"
proof -
have 1: "test_set { t i | i . i ∈ {..<m} }"
using assms test_seq_test_set test_set_def by auto
have "∀y∈{ t i | i . i ∈ {..<m} } . y ≤ --pSum t m"
using assms pSum_test pSum_upper by force
hence 2: "Sup { t i | i . i ∈ {..<m} } ≤ --pSum t m"
using 1 by (simp add: sup_least)
have "pSum t m ≤ Sup { t i | i . i ∈ {..<m} }"
proof (induct m)
case 0
show ?case
by (smt (verit, ccfv_SIG) Collect_empty_eq empty_iff lessThan_0 pSum.simps(1) sup_test test_set_def tests_dual.top_greatest)
next
case (Suc n)
have 4: "test_set {t i |i. i ∈ {..<n}}"
using assms test_seq_def test_set_def by auto
have 5: "test_set {t i |i. i < Suc n}"
using assms test_seq_def test_set_def by force
hence 6: "Sup {t i |i. i < Suc n} = --Sup {t i |i. i < Suc n}"
using sup_test by auto
hence "∀x∈{t i |i. i ∈ {..<n}} . x ≤ --Sup {t i |i. i < Suc n}"
using 5 less_Suc_eq sup_upper by fastforce
hence 7: "Sup {t i |i. i ∈ {..<n}} ≤ --Sup {t i |i. i < Suc n}"
using 4 by (simp add: sup_least)
have "t n ∈ {t i |i. i < Suc n}"
by auto
hence "t n ≤ Sup {t i |i. i < Suc n}"
using 5 by (simp add: sup_upper)
hence "pSum t n ⊔ t n ≤ Sup {t i |i. i <Suc n}"
using Suc 4 6 7 by (smt assms tests_dual.greatest_lower_bound test_seq_def pSum_test tests_dual.sba_dual.transitive sup_test)
thus ?case
by simp
qed
thus ?thesis
using 1 2 by (smt assms tests_dual.antisymmetric sup_test pSum_test)
qed
definition Prod :: "(nat ⇒ 'a) ⇒ 'a"
where "Prod f ≡ Inf { f n | n::nat . True }"
lemma Sum_range:
"Sum f = Sup (range f)"
by (simp add: Sum_def image_def)
lemma Prod_range:
"Prod f = Inf (range f)"
by (simp add: Prod_def image_def)
end
end
Theory Complete_Domain
section ‹Complete Domain›
theory Complete_Domain
imports Relative_Domain Complete_Tests
begin
class complete_antidomain_semiring = relative_antidomain_semiring + complete_tests +
assumes a_dist_Sum: "ascending_chain f ⟶ -(Sum f) = Prod (λn . -f n)"
assumes a_dist_Prod: "descending_chain f ⟶ -(Prod f) = Sum (λn . -f n)"
begin
lemma a_ascending_chain:
"ascending_chain f ⟹ descending_chain (λn . -f n)"
by (simp add: a_antitone ascending_chain_def descending_chain_def)
lemma a_descending_chain:
"descending_chain f ⟹ ascending_chain (λn . -f n)"
by (simp add: a_antitone ord.ascending_chain_def ord.descending_chain_def)
lemma d_dist_Sum:
"ascending_chain f ⟹ d(Sum f) = Sum (λn . d(f n))"
by (simp add: d_def a_ascending_chain a_dist_Prod a_dist_Sum)
lemma d_dist_Prod:
"descending_chain f ⟹ d(Prod f) = Prod (λn . d(f n))"
by (simp add: d_def a_dist_Sum a_dist_Prod a_descending_chain)
end
end
Theory Preconditions
section ‹Preconditions›
theory Preconditions
imports Tests
begin
class pre =
fixes pre :: "'a ⇒ 'a ⇒ 'a" (infixr "«" 55)
class precondition = tests + pre +
assumes pre_closed: "x«-q = --(x«-q)"
assumes pre_seq: "x*y«-q = x«y«-q"
assumes pre_lower_bound_right: "x«-p*-q ≤ x«-q"
assumes pre_one_increasing: "-q ≤ 1«-q"
begin
text ‹Theorem 39.2›
lemma pre_sub_distr:
"x«-p*-q ≤ (x«-p)*(x«-q)"
by (smt (z3) pre_closed pre_lower_bound_right tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.least_upper_bound)
text ‹Theorem 39.5›
lemma pre_below_one:
"x«-p ≤ 1"
by (metis pre_closed tests_dual.sub_bot_least)
lemma pre_lower_bound_left:
"x«-p*-q ≤ x«-p"
using pre_lower_bound_right tests_dual.sub_commutative by fastforce
text ‹Theorem 39.1›
lemma pre_iso:
"-p ≤ -q ⟹ x«-p ≤ x«-q"
by (metis leq_def pre_lower_bound_right)
text ‹Theorem 39.4 and Theorem 40.9›
lemma pre_below_pre_one:
"x«-p ≤ x«1"
using tests_dual.sba_dual.one_def pre_iso tests_dual.sub_bot_least by blast
text ‹Theorem 39.3›
lemma pre_seq_below_pre_one:
"x*y«1 ≤ x«1"
by (metis one_def pre_below_pre_one pre_closed pre_seq)
text ‹Theorem 39.6›
lemma pre_compose:
"-p ≤ x«-q ⟹ -q ≤ y«-r ⟹ -p ≤ x*y«-r"
by (metis pre_closed pre_iso tests_dual.transitive pre_seq)
end
class precondition_test_test = precondition +
assumes pre_test_test: "-p*(-p«-q) = -p*-q"
begin
lemma pre_one:
"1«-p = -p"
by (metis pre_closed pre_test_test tests_dual.sba_dual.one_def tests_dual.sup_left_unit)
lemma pre_import:
"-p*(x«-q) = -p*(-p*x«-q)"
by (metis pre_closed pre_seq pre_test_test)
lemma pre_import_composition:
"-p*(-p*x*y«-q) = -p*(x«y«-q)"
by (metis pre_closed pre_seq pre_import)
lemma pre_import_equiv:
"-p ≤ x«-q ⟷ -p ≤ -p*x«-q"
by (metis leq_def pre_closed pre_import)
lemma pre_import_equiv_mult:
"-p*-q ≤ x«-s ⟷ -p*-q ≤ -q*x«-s"
by (smt leq_def pre_closed sub_assoc sub_mult_closed pre_import)
end
class precondition_promote = precondition +
assumes pre_test_promote: "-p«-q = -p«-p*-q"
begin
lemma pre_mult_test_promote:
"x*-p«-q = x*-p«-p*-q"
by (metis pre_seq pre_test_promote sub_mult_closed)
end
class precondition_test_box = precondition +
assumes pre_test: "-p«-q = --p⊔-q"
begin
lemma pre_test_neg:
"--p*(-p«-q) = --p"
by (simp add: pre_test)
lemma pre_bot:
"bot«-q = 1"
by (metis pre_test tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_left_zero tests_dual.top_double_complement)
lemma pre_export:
"-p*x«-q = --p⊔(x«-q)"
by (metis pre_closed pre_seq pre_test)
lemma pre_neg_mult:
"--p ≤ -p*x«-q"
by (metis leq_def pre_closed pre_seq pre_test_neg)
lemma pre_test_test_same:
"-p«-p = 1"
using pre_test tests_dual.sba_dual.less_eq_sup_top tests_dual.sba_dual.reflexive by auto
lemma test_below_pre_test_mult:
"-q ≤ -p«-p*-q"
by (metis pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.shunting tests_dual.sub_sup_closed)
lemma test_below_pre_test:
"-q ≤ -p«-q"
by (simp add: pre_test tests_dual.sba_dual.upper_bound_right)
lemma test_below_pre_test_2:
"--p ≤ -p«-q"
by (simp add: pre_test tests_dual.sba_dual.upper_bound_left)
lemma pre_test_bot:
"-p«bot = --p"
by (metis pre_test tests_dual.sba_dual.sup_right_unit tests_dual.top_double_complement)
lemma pre_test_one:
"-p«1 = 1"
by (metis pre_seq pre_bot tests_dual.sup_right_zero)
subclass precondition_test_test
apply unfold_locales
by (simp add: pre_test tests_dual.sup_complement_intro)
subclass precondition_promote
apply unfold_locales
by (metis pre_test tests_dual.sba_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.inf_complement_intro)
end
class precondition_test_diamond = precondition +
assumes pre_test: "-p«-q = -p*-q"
begin
lemma pre_test_neg:
"--p*(-p«-q) = bot"
by (simp add: pre_test tests_dual.sub_associative tests_dual.sub_commutative)
lemma pre_bot:
"bot«-q = bot"
by (metis pre_test tests_dual.sup_left_zero tests_dual.top_double_complement)
lemma pre_export:
"-p*x«-q = -p*(x«-q)"
by (metis pre_closed pre_seq pre_test)
lemma pre_neg_mult:
"-p*x«-q ≤ -p"
by (metis pre_closed pre_export tests_dual.upper_bound_left)
lemma pre_test_test_same:
"-p«-p = -p"
by (simp add: pre_test)
lemma test_above_pre_test_plus:
"--p«-p⊔-q ≤ -q"
using pre_test tests_dual.sba_dual.inf_complement_intro tests_dual.sub_commutative tests_dual.sub_inf_def tests_dual.upper_bound_left by auto
lemma test_above_pre_test:
"-p«-q ≤ -q"
by (simp add: pre_test tests_dual.upper_bound_right)
lemma test_above_pre_test_2:
"-p«-q ≤ -p"
by (simp add: pre_test tests_dual.upper_bound_left)
lemma pre_test_bot:
"-p«bot = bot"
by (metis pre_test tests_dual.sup_right_zero tests_dual.top_double_complement)
lemma pre_test_one:
"-p«1 = -p"
by (metis pre_test tests_dual.complement_top tests_dual.sup_right_unit)
subclass precondition_test_test
apply unfold_locales
by (simp add: pre_test tests_dual.sub_associative)
subclass precondition_promote
apply unfold_locales
by (metis pre_seq pre_test tests_dual.sup_idempotent)
end
class precondition_distr_mult = precondition +
assumes pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)"
begin
end
class precondition_distr_plus = precondition +
assumes pre_distr_plus: "x«-p⊔-q = (x«-p)⊔(x«-q)"
begin
end
end
Theory Hoare
section ‹Hoare Calculus›
theory Hoare
imports Complete_Tests Preconditions
begin
class ite =
fixes ite :: "'a ⇒ 'a ⇒ 'a ⇒ 'a" ("_ ⊲ _ ⊳ _" [58,58,58] 57)
class hoare_triple =
fixes hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⦃ _ ⦄ _" [54,54,54] 53)
class ifthenelse = precondition + ite +
assumes ite_pre: "x⊲-p⊳y«-q = -p*(x«-q) ⊔ --p*(y«-q)"
begin
text ‹Theorem 40.2›
lemma ite_pre_then:
"-p*(x⊲-p⊳y«-q) = -p*(x«-q)"
proof -
have "-p*(x⊲-p⊳y«-q) = -p*(x«-q) ⊔ bot*(y«-q)"
by (smt (z3) ite_pre pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_commutative tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_1)
thus ?thesis
by (metis pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_left_zero)
qed
text ‹Theorem 40.3›
lemma ite_pre_else:
"--p*(x⊲-p⊳y«-q) = --p*(y«-q)"
proof -
have "--p*(x⊲-p⊳y«-q) = bot*(x«-q) ⊔ --p*(y«-q)"
by (smt (z3) ite_pre pre_closed tests_dual.sub_commutative tests_dual.sub_inf_left_zero tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_3)
thus ?thesis
by (metis pre_closed tests_dual.sba_dual.sub_sup_demorgan tests_dual.sub_inf_left_zero tests_dual.sup_left_zero)
qed
lemma ite_import_mult_then:
"-p*-q ≤ x«-r ⟹ -p*-q ≤ x⊲-p⊳y«-r"
by (smt ite_pre_then leq_def pre_closed sub_assoc sub_comm sub_mult_closed)
lemma ite_import_mult_else:
"--p*-q ≤ y«-r ⟹ --p*-q ≤ x⊲-p⊳y«-r"
by (smt ite_pre_else leq_def pre_closed sub_assoc sub_comm sub_mult_closed)
text ‹Theorem 40.1›
lemma ite_import_mult:
"-p*-q ≤ x«-r ⟹ --p*-q ≤ y«-r ⟹ -q ≤ x⊲-p⊳y«-r"
by (smt (verit) ite_import_mult_else ite_import_mult_then pre_closed tests_dual.sba_dual.inf_less_eq_cases)
end
class whiledo = ifthenelse + while +
assumes while_pre: "-p⋆x«-q = -p*(x«-p⋆x«-q) ⊔ --p*-q"
assumes while_post: "-p⋆x«-q = -p⋆x«--p*-q"
begin
text ‹Theorem 40.4›
lemma while_pre_then:
"-p*(-p⋆x«-q) = -p*(x«-p⋆x«-q)"
by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_1)
text ‹Theorem 40.5›
lemma while_pre_else:
"--p*(-p⋆x«-q) = --p*-q"
by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_3)
text ‹Theorem 40.6›
lemma while_pre_sub_1:
"-p⋆x«-q ≤ x*(-p⋆x)⊲-p⊳1«-q"
by (smt (z3) ite_import_mult pre_closed pre_one_increasing pre_seq tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_else while_pre_then)
text ‹Theorem 40.7›
lemma while_pre_sub_2:
"-p⋆x«-q ≤ x⊲-p⊳1«-p⋆x«-q"
by (smt (z3) ite_import_mult pre_closed pre_one_increasing tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_then)
text ‹Theorem 40.8›
lemma while_pre_compl:
"--p ≤ -p⋆x«--p"
by (metis pre_closed tests_dual.sup_idempotent tests_dual.upper_bound_right while_pre_else)
lemma while_pre_compl_one:
"--p ≤ -p⋆x«1"
by (metis tests_dual.sba_dual.top_double_complement while_post tests_dual.sup_right_unit while_pre_compl)
text ‹Theorem 40.10›
lemma while_export_equiv:
"-q ≤ -p⋆x«1 ⟷ -p*-q ≤ -p⋆x«1"
by (smt pre_closed tests_dual.sba_dual.shunting tests_dual.sba_dual.sub_less_eq_def tests_dual.sba_dual.top_double_complement while_pre_compl_one)
lemma nat_test_pre:
assumes "nat_test t s"
and "-q ≤ s"
and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
shows "-q ≤ -p⋆x«--p*-q"
proof -
have 1: "-q*--p ≤ -p⋆x«--p*-q"
by (metis pre_closed tests_dual.sub_commutative while_post tests_dual.upper_bound_right while_pre_else)
have "∀n . t n*-p*-q ≤ -p⋆x«--p*-q"
proof
fix n
show "t n*-p*-q ≤ -p⋆x«--p*-q"
proof (induct n rule: nat_less_induct)
fix n
have 2: "t n = --(t n)"
using assms(1) nat_test_def by auto
assume "∀m<n . t m*-p*-q ≤ -p⋆x«--p*-q"
hence "∀m<n . t m*-p*-q ⊔ t m*--p*-q ≤ -p⋆x«--p*-q"
using 1 by (smt (verit, del_insts) assms(1) tests_dual.greatest_lower_bound leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
hence "∀m<n . t m*-q ≤ -p⋆x«--p*-q"
by (smt (verit, del_insts) assms(1) tests_dual.sup_right_unit tests_dual.sup_left_dist_inf tests_dual.sup_right_dist_inf nat_test_def tests_dual.inf_complement sub_mult_closed)
hence "pSum t n*-q ≤ -p⋆x«--p*-q"
by (smt assms(1) pSum_below_nat pre_closed sub_mult_closed)
hence "t n*-p*-q*(-p⋆x«--p*-q) = t n*-p*-q"
using 2 by (smt assms(1,3) leq_def pSum_test_nat pre_closed pre_sub_distr sub_assoc sub_comm sub_mult_closed transitive while_pre_then)
thus "t n*-p*-q ≤ -p⋆x«--p*-q"
using 2 by (smt (z3) pre_closed tests_dual.sub_sup_closed tests_dual.upper_bound_right)
qed
qed
hence "-q*-p ≤ -p⋆x«--p*-q"
by (smt (verit, del_insts) assms(1,2) leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
thus ?thesis
using 1 by (smt (z3) pre_closed tests_dual.sba_dual.inf_less_eq_cases tests_dual.sub_commutative tests_dual.sub_sup_closed)
qed
lemma nat_test_pre_1:
assumes "nat_test t s"
and "-r ≤ s"
and "-r ≤ -q"
and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
shows "-r ≤ -p⋆x«--p*-q"
proof -
let ?qs = "-q*s"
have 1: "-r ≤ ?qs"
by (metis assms(1-3) nat_test_def tests_dual.least_upper_bound)
have "∀n . t n*-p*?qs ≤ x«pSum t n*?qs"
proof
fix n
have 2: "pSum t n ≤ s"
by (simp add: assms(1) pSum_below_sum)
have "t n = t n * s"
by (metis assms(1) nat_test_def tests_dual.sba_dual.less_eq_inf)
hence "t n*-p*?qs = t n*-p*-q"
by (smt (verit, ccfv_threshold) assms(1) nat_test_def tests_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_commutative)
also have "t n*-p*-q ≤ x«pSum t n*-q"
by (simp add: assms(4))
also have "x«pSum t n*-q = x«pSum t n*?qs"
using 2 by (smt (verit, ccfv_SIG) assms(1) leq_def nat_test_def pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
finally show "t n*-p*?qs ≤ x«pSum t n*?qs"
.
qed
hence 3: "?qs ≤ -p⋆x«--p*?qs"
by (smt (verit, ccfv_threshold) assms(1) tests_dual.upper_bound_left tests_dual.upper_bound_right nat_test_def nat_test_pre pSum_test_nat pre_closed tests_dual.sub_associative sub_mult_closed transitive)
have "-p⋆x«--p*?qs ≤ -p⋆x«--p*-q"
by (metis assms(1) nat_test_def pre_lower_bound_left tests_dual.sub_sup_closed while_post)
thus ?thesis
using 1 3 by (smt (verit, del_insts) leq_def tests_dual.sub_associative assms(1) nat_test_def pre_closed sub_mult_closed)
qed
lemma nat_test_pre_2:
assumes "nat_test t s"
and "-r ≤ s"
and "∀n . t n*-p ≤ x«pSum t n"
shows "-r ≤ -p⋆x«1"
proof -
have 1: "-r ≤ -p⋆x«--p*s"
by (smt (verit, ccfv_threshold) assms leq_def nat_test_def nat_test_pre_1 pSum_below_sum pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
have "-p⋆x«--p*s ≤ -p⋆x«1"
by (metis assms(1) nat_test_def pre_below_pre_one while_post)
thus ?thesis
using 1 by (smt (verit) assms(1) nat_test_def pre_closed tests_dual.sba_dual.top_double_complement while_post tests_dual.transitive)
qed
lemma nat_test_pre_3:
assumes "nat_test t s"
and "-q ≤ s"
and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
shows "-q ≤ -p⋆x«1"
proof -
have "-p⋆x«--p*-q ≤ -p⋆x«1"
by (metis pre_below_pre_one sub_mult_closed)
thus ?thesis
by (smt (verit, ccfv_threshold) assms pre_closed tests_dual.sba_dual.top_double_complement tests_dual.sba_dual.transitive tests_dual.sub_sup_closed nat_test_pre)
qed
definition aL :: "'a"
where "aL ≡ 1⋆1«1"
lemma aL_test:
"aL = --aL"
by (metis aL_def one_def pre_closed)
end
class atoms = tests +
fixes Atomic_program :: "'a set"
fixes Atomic_test :: "'a set"
assumes one_atomic_program: "1 ∈ Atomic_program"
assumes zero_atomic_test: "bot ∈ Atomic_test"
assumes atomic_test_test: "p ∈ Atomic_test ⟶ p = --p"
class while_program = whiledo + atoms + power
begin
inductive_set Test_expression :: "'a set"
where atom_test: "p ∈ Atomic_test ⟹ p ∈ Test_expression"
| neg_test: "p ∈ Test_expression ⟹ -p ∈ Test_expression"
| conj_test: "p ∈ Test_expression ⟹ q ∈ Test_expression ⟹ p*q ∈ Test_expression"
lemma test_expression_test:
"p ∈ Test_expression ⟹ p = --p"
apply (induct rule: Test_expression.induct)
apply (simp add: atomic_test_test)
apply simp
by (metis tests_dual.sub_sup_closed)
lemma disj_test:
"p ∈ Test_expression ⟹ q ∈ Test_expression ⟹ p⊔q ∈ Test_expression"
by (smt conj_test neg_test tests_dual.sub_inf_def test_expression_test)
lemma zero_test_expression:
"bot ∈ Test_expression"
by (simp add: Test_expression.atom_test zero_atomic_test)
lemma one_test_expression:
"1 ∈ Test_expression"
using Test_expression.simps tests_dual.sba_dual.one_def zero_test_expression by blast
lemma pSum_test_expression:
"(∀n . t n ∈ Test_expression) ⟹ pSum t m ∈ Test_expression"
apply (induct m)
apply (simp add: zero_test_expression)
by (simp add: disj_test)
inductive_set While_program :: "'a set"
where atom_prog: "x ∈ Atomic_program ⟹ x ∈ While_program"
| seq_prog: "x ∈ While_program ⟹ y ∈ While_program ⟹ x*y ∈ While_program"
| cond_prog: "p ∈ Test_expression ⟹ x ∈ While_program ⟹ y ∈ While_program ⟹ x⊲p⊳y ∈ While_program"
| while_prog: "p ∈ Test_expression ⟹ x ∈ While_program ⟹ p⋆x ∈ While_program"
lemma one_while_program:
"1 ∈ While_program"
by (simp add: While_program.atom_prog one_atomic_program)
lemma power_while_program:
"x ∈ While_program ⟹ x^m ∈ While_program"
apply (induct m)
apply (simp add: one_while_program)
by (simp add: While_program.seq_prog)
inductive_set Pre_expression :: "'a set"
where test_pre: "p ∈ Test_expression ⟹ p ∈ Pre_expression"
| neg_pre: "p ∈ Pre_expression ⟹ -p ∈ Pre_expression"
| conj_pre: "p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ p*q ∈ Pre_expression"
| pre_pre: "p ∈ Pre_expression ⟹ x ∈ While_program ⟹ x«p ∈ Pre_expression"
lemma pre_expression_test:
"p ∈ Pre_expression ⟹ p = --p"
apply (induct rule: Pre_expression.induct)
apply (simp add: test_expression_test)
apply simp
apply (metis sub_mult_closed)
by (metis pre_closed)
lemma disj_pre:
"p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ p⊔q ∈ Pre_expression"
by (smt conj_pre neg_pre tests_dual.sub_inf_def pre_expression_test)
lemma zero_pre_expression:
"bot ∈ Pre_expression"
by (simp add: Pre_expression.test_pre zero_test_expression)
lemma one_pre_expression:
"1 ∈ Pre_expression"
by (simp add: Pre_expression.test_pre one_test_expression)
lemma pSum_pre_expression:
"(∀n . t n ∈ Pre_expression) ⟹ pSum t m ∈ Pre_expression"
apply (induct m)
apply (simp add: zero_pre_expression)
by (simp add: disj_pre)
lemma aL_pre_expression:
"aL ∈ Pre_expression"
by (simp add: Pre_expression.pre_pre While_program.while_prog aL_def one_pre_expression one_test_expression one_while_program)
end
class hoare_calculus = while_program + complete_tests
begin
definition tfun :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
where "tfun p x q r ≡ p ⊔ (x«q*r)"
lemma tfun_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ tfun p x q r = --tfun p x q r"
by (smt tfun_def sub_mult_closed pre_closed tests_dual.inf_closed)
lemma tfun_pre_expression:
"x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ tfun p x q r ∈ Pre_expression"
by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun_def)
lemma tfun_iso:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ r ≤ s ⟹ tfun p x q r ≤ tfun p x q s"
by (smt tfun_def tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed tests_dual.sub_inf_right_isotone pre_closed)
definition tseq :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ nat ⇒ 'a"
where "tseq p x q r m ≡ (tfun p x q ^ m) r"
lemma tseq_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ tseq p x q r m = --tseq p x q r m"
apply (induct m)
apply (smt tseq_def tfun_test power_zero_id id_def)
by (metis tseq_def tfun_test power_succ_unfold_ext)
lemma tseq_test_seq:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ test_seq (tseq p x q r)"
using test_seq_def tseq_test by auto
lemma tseq_pre_expression:
"x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ tseq p x q r m ∈ Pre_expression"
apply (induct m)
apply (smt tseq_def id_def power_zero_id)
by (smt tseq_def power_succ_unfold_ext tfun_pre_expression)
definition tsum :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
where "tsum p x q r ≡ Sum (tseq p x q r)"
lemma tsum_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ tsum p x q r = --tsum p x q r"
using Sum_test tseq_test_seq tsum_def by auto
lemma t_fun_test:
"q = --q ⟹ tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) = --tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test)
lemma t_fun_pre_expression:
"x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) ∈ Pre_expression"
by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun_pre_expression)
lemma t_seq_test:
"q = --q ⟹ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m = --tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m"
by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test tseq_test)
lemma t_seq_test_seq:
"q = --q ⟹ test_seq (tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)))"
using test_seq_def t_seq_test by auto
lemma t_seq_pre_expression:
"x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m ∈ Pre_expression"
using Pre_expression.pre_pre Pre_expression.test_pre Test_expression.neg_test While_program.while_prog aL_pre_expression tfun_def tfun_pre_expression tseq_pre_expression by auto
lemma t_sum_test:
"q = --q ⟹ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) = --tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
using Sum_test t_seq_test_seq tsum_def by auto
definition tfun2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
where "tfun2 p q x r s ≡ p ⊔ q*(x«r*s)"
lemma tfun2_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tfun2 p q x r s = --tfun2 p q x r s"
by (smt tfun2_def sub_mult_closed pre_closed tests_dual.inf_closed)
lemma tfun2_pre_expression:
"x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ tfun2 p q x r s ∈ Pre_expression"
by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun2_def)
lemma tfun2_iso:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s1 = --s1 ⟹ s2 = --s2 ⟹ s1 ≤ s2 ⟹ tfun2 p q x r s1 ≤ tfun2 p q x r s2"
by (smt tfun2_def tests_dual.sub_inf_right_isotone pre_iso sub_mult_closed tests_dual.sub_sup_right_isotone pre_closed)
definition tseq2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ nat ⇒ 'a"
where "tseq2 p q x r s m ≡ (tfun2 p q x r ^ m) s"
lemma tseq2_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tseq2 p q x r s m = --tseq2 p q x r s m"
apply (induct m)
apply (smt tseq2_def power_zero_id id_def)
by (smt tseq2_def tfun2_test power_succ_unfold_ext)
lemma tseq2_test_seq:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ test_seq (tseq2 p q x r s)"
using test_seq_def tseq2_test by force
lemma tseq2_pre_expression:
"x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ tseq2 p q x r s m ∈ Pre_expression"
apply (induct m)
apply (smt tseq2_def id_def power_zero_id)
by (smt tseq2_def power_succ_unfold_ext tfun2_pre_expression)
definition tsum2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
where "tsum2 p q x r s ≡ Sum (tseq2 p q x r s)"
lemma tsum2_test:
"p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tsum2 p q x r s = --tsum2 p q x r s"
using Sum_test tseq2_test_seq tsum2_def by force
lemma t_fun2_test:
"p = --p ⟹ q = --q ⟹ tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = --tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test)
lemma t_fun2_pre_expression:
"x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ∈ Pre_expression"
by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun2_pre_expression)
lemma t_seq2_test:
"p = --p ⟹ q = --q ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m = --tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m"
by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test tseq2_test)
lemma t_seq2_test_seq:
"p = --p ⟹ q = --q ⟹ test_seq (tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)))"
using test_seq_def t_seq2_test by auto
lemma t_seq2_pre_expression:
"x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ∈ Pre_expression"
by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tseq2_pre_expression)
lemma t_sum2_test:
"p = --p ⟹ q = --q ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = --tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
using Sum_test t_seq2_test_seq tsum2_def by auto
lemma t_seq2_below_t_seq:
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
shows "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m"
proof -
let ?t2 = "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
let ?t = "tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
show "?thesis"
proof (induct m)
case 0
show "?t2 0 ≤ ?t 0"
by (smt assms aL_test id_def tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_zero_id pre_closed pre_expression_test sub_mult_closed test_pre tseq2_def tseq_def)
next
fix m
assume "?t2 m ≤ ?t m"
hence 1: "?t2 (Suc m) ≤ tfun2 (- p * q) p x (p ⋆ x « q) (?t m)"
by (smt assms power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq2_test t_seq_test test_pre tfun2_iso tseq2_def)
have "... ≤ ?t (Suc m)"
by (smt assms tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq_test test_pre tfun2_def tfun_def tseq_def)
thus "?t2 (Suc m) ≤ ?t (Suc m)"
using 1 by (smt (verit, del_insts) assms pre_closed pre_expression_test test_expression_test tests_dual.sba_dual.transitive tests_dual.sub_sup_closed t_seq2_test t_seq_test tfun2_test)
qed
qed
lemma t_seq2_below_t_sum:
"p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
by (smt (verit, del_insts) Sum_upper pre_expression_test t_seq2_below_t_seq t_seq2_test t_seq_test t_sum_test test_pre test_seq_def tsum_def leq_def tests_dual.sub_associative)
lemma t_sum2_below_t_sum:
"p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
by (smt Sum_least pre_expression_test t_seq2_below_t_sum t_seq2_test t_sum_test test_pre test_seq_def tsum2_def)
lemma t_seq2_below_w:
"p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ p⋆x«q"
apply (cases m)
apply (smt aL_test id_def tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone power_zero_id pre_closed pre_expression_test pre_iso sub_mult_closed test_pre tseq2_def while_pre)
by (smt tseq2_def power_succ_unfold_ext tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone pre_closed pre_expression_test pre_iso sub_mult_closed t_seq2_test test_pre tseq2_def while_pre tfun2_def)
lemma t_sum2_below_w:
"p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ≤ p⋆x«q"
by (smt Sum_least pre_closed pre_expression_test t_seq2_below_w t_seq2_test_seq test_pre tsum2_def)
lemma t_sum2_w:
assumes "aL = 1"
and "p ∈ Test_expression"
and "q ∈ Pre_expression"
and "x ∈ While_program"
shows "tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = p⋆x«q"
proof -
let ?w = "p⋆x«q"
let ?s = "-p*q⊔p*(x«?w*aL)"
have "?w = tseq2 (-p*q) p x ?w ?s 0"
by (smt assms(1-3) tests_dual.sup_right_unit id_def tests_dual.inf_commutative power_zero_id pre_closed pre_expression_test sub_mult_closed test_expression_test tseq2_def while_pre)
hence "?w ≤ tsum2 (-p*q) p x ?w ?s"
by (smt assms(2,3) Sum_upper pre_expression_test t_seq2_test_seq test_pre tsum2_def)
thus ?thesis
by (smt assms(2-4) tests_dual.antisymmetric pre_closed pre_expression_test t_sum2_test t_sum2_below_w test_pre)
qed
inductive derived_hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⦇ _ ⦈ _" [54,54,54] 53)
where atom_trip: "p ∈ Pre_expression ⟹ x ∈ Atomic_program ⟹ x«p⦇x⦈p"
| seq_trip: "p⦇x⦈q ∧ q⦇y⦈r ⟹ p⦇x*y⦈r"
| cond_trip: "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ p*q⦇x⦈r ∧ -p*q⦇y⦈r ⟹ q⦇x⊲p⊳y⦈r"
| while_trip: "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ test_seq t ∧ q ≤ Sum t ⟹ t 0*p*q⦇x⦈aL*q ⟹ (∀n>0 . t n*p*q⦇x⦈pSum t n*q) ⟹ q⦇p⋆x⦈-p*q"
| cons_trip: "p ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ p ≤ q ∧ q⦇x⦈r ⟹ r ≤ s ⟹ p⦇x⦈s"
lemma derived_type:
"p⦇x⦈q ⟹ p ∈ Pre_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program"
apply (induct rule: derived_hoare_triple.induct)
apply (simp add: Pre_expression.pre_pre While_program.atom_prog)
using While_program.seq_prog apply blast
using While_program.cond_prog apply blast
using Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog apply simp
by blast
lemma cons_pre_trip:
"p ∈ Pre_expression ⟹ q⦇y⦈r ⟹ p*q⦇y⦈r"
by (metis cons_trip derived_type Pre_expression.conj_pre pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)
lemma cons_post_trip:
"q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ p⦇y⦈q*r ⟶ p⦇y⦈r"
by (metis cons_trip derived_type pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)
definition valid_hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⟨ _ ⟩ _" [54,54,54] 53)
where "p⟨x⟩q ≡ (p ∈ Pre_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program ∧ p ≤ x«q)"
end
class hoare_calculus_sound = hoare_calculus +
assumes while_soundness: "-p*-q ≤ x«-q ⟶ aL*-q ≤ -p⋆x«-q"
begin
lemma while_soundness_0:
"-p*-q ≤ x«-q ⟹ -q*aL ≤ -p⋆x«--p*-q"
by (smt while_soundness aL_test sub_comm while_post)
lemma while_soundness_1:
assumes "test_seq t"
and "-q ≤ Sum t"
and "t 0*-p*-q ≤ x«aL*-q"
and "∀n>0 . t n*-p*-q ≤ x«pSum t n*-q"
shows "-q ≤ -p⋆x«--p*-q"
proof -
have "∀n . t n*-p*-q ≤ x«-q"
proof
fix n
show "t n*-p*-q ≤ x«-q"
proof (cases n)
case 0
thus ?thesis
by (smt (z3) assms(1) assms(3) aL_test leq_def pre_closed pre_lower_bound_right test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
next
case (Suc m)
hence 1: "t n*-p*-q ≤ x«pSum t n*-q"
using assms(4) by blast
have "x«pSum t n*-q ≤ x«-q"
by (metis assms(1) pSum_test pre_lower_bound_right)
thus ?thesis
using 1 by (smt (verit, del_insts) assms(1) pSum_test pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
qed
qed
hence 2: "-p*-q ≤ x«-q"
by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_assoc sub_comm sub_mult_closed test_seq_def)
have "∀n . t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
proof
fix n
show "t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
proof (induct n rule: nat_less_induct)
fix n
assume 3: "∀m<n . t m*-q ≤ -p⋆x«--p*-q ∧ pSum t m*-q ≤ -p⋆x«--p*-q"
have 4: "pSum t n*-q ≤ -p⋆x«--p*-q"
proof (cases n)
case 0
thus ?thesis
by (metis pSum.simps(1) pre_closed sub_mult_closed tests_dual.top_greatest tests_dual.sba_dual.less_eq_inf tests_dual.top_double_complement)
next
case (Suc m)
hence "pSum t n*-q = (pSum t m ⊔ t m)*-q"
by simp
also have "... = pSum t m*-q ⊔ t m*-q"
by (metis (full_types) assms(1) pSum_test test_seq_def tests_dual.sup_right_dist_inf)
also have "... ≤ -p⋆x«--p*-q"
proof -
have "pSum t m*-q = --(pSum t m*-q) ∧ t m*-q = --(t m*-q) ∧ -p⋆x«--p*-q = --(-p⋆x«--p*-q)"
apply (intro conjI)
apply (metis assms(1) pSum_test tests_dual.sub_sup_closed)
apply (metis assms(1) test_seq_def tests_dual.sub_sup_closed)
by (metis pre_closed tests_dual.sub_sup_closed)
thus ?thesis
using 3 by (smt (z3) lessI Suc tests_dual.greatest_lower_bound sub_mult_closed)
qed
finally show ?thesis
.
qed
hence 5: "x«pSum t n*-q ≤ x«-p⋆x«--p*-q"
by (smt assms pSum_test pre_closed pre_iso sub_mult_closed)
have 6: "-p*(t n*-q) ≤ -p*(-p⋆x«--p*-q)"
proof (cases n)
case 0
thus ?thesis
using 2 by (smt assms(1,3) aL_test leq_def tests_dual.sup_idempotent tests_dual.sub_sup_right_isotone pre_closed pre_lower_bound_left sub_assoc sub_comm sub_mult_closed test_seq_def transitive while_pre_then while_soundness_0)
next
case (Suc m)
hence "-p*(t n*-q) ≤ x«pSum t n*-q"
by (smt assms(1,4) test_seq_def tests_dual.sub_associative tests_dual.sub_commutative zero_less_Suc)
hence "-p*(t n*-q) ≤ x«-p⋆x«--p*-q"
using 5 by (smt assms(1) tests_dual.least_upper_bound pSum_test pre_closed sub_mult_closed test_seq_def leq_def)
hence "-p*(t n*-q) ≤ -p*(x«-p⋆x«--p*-q)"
by (smt assms(1) tests_dual.upper_bound_left pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
thus ?thesis
using while_post while_pre_then by auto
qed
have "--p*(t n*-q) ≤ --p*(-p⋆x«--p*-q)"
by (smt assms(1) leq_def tests_dual.upper_bound_right sub_assoc sub_comm sub_mult_closed test_seq_def while_pre_else)
thus "t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
using 4 6 by (smt assms(1) tests_dual.sup_less_eq_cases_2 pre_closed sub_mult_closed test_seq_def)
qed
qed
thus ?thesis
by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_comm sub_mult_closed)
qed
lemma while_soundness_2:
assumes "test_seq t"
and "-r ≤ Sum t"
and "∀n . t n*-p ≤ x«pSum t n"
shows "-r ≤ -p⋆x«1"
proof -
have 1: "∀n>0 . t n*-p*Sum t ≤ x«pSum t n*Sum t"
by (smt (z3) assms(1,3) Sum_test Sum_upper leq_def pSum_below_Sum pSum_test test_seq_def tests_dual.sub_associative tests_dual.sub_commutative)
have 2: "t 0*-p*Sum t ≤ x«bot"
by (smt assms(1,3) Sum_test Sum_upper leq_def sub_assoc sub_comm test_seq_def pSum.simps(1))
have "x«bot ≤ x«aL*Sum t"
by (smt assms(1) Sum_test aL_test pre_iso sub_mult_closed tests_dual.top_double_complement tests_dual.top_greatest)
hence "t 0*-p*Sum t ≤ x«aL*Sum t"
using 2 by (smt (z3) assms(1) Sum_test aL_test leq_def pSum.simps(1) pSum_test pre_closed test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
hence 3: "Sum t ≤ -p⋆x«--p*Sum t"
using 1 by (smt (verit, del_insts) assms(1) Sum_test tests_dual.sba_dual.one_def tests_dual.sup_right_unit tests_dual.upper_bound_left while_soundness_1)
have "-p⋆x«--p*Sum t ≤ -p⋆x«1"
by (metis assms(1) Sum_test pre_below_pre_one tests_dual.sub_sup_closed)
hence "Sum t ≤ -p⋆x«1"
using 3 by (smt (z3) assms(1) Sum_test pre_closed tests_dual.sba_dual.one_def while_post tests_dual.transitive)
thus ?thesis
by (smt (z3) assms(1,2) Sum_test pre_closed tests_dual.sba_dual.one_def tests_dual.transitive)
qed
theorem soundness:
"p⦇x⦈q ⟹ p⟨x⟩q"
apply (induct rule: derived_hoare_triple.induct)
apply (metis Pre_expression.pre_pre While_program.atom_prog pre_expression_test tests_dual.sba_dual.reflexive valid_hoare_triple_def)
apply (metis valid_hoare_triple_def pre_expression_test pre_compose While_program.seq_prog)
apply (metis valid_hoare_triple_def ite_import_mult pre_expression_test cond_prog test_pre)
apply (smt (verit, del_insts) Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog pre_expression_test valid_hoare_triple_def while_soundness_1)
by (metis pre_expression_test pre_iso pre_pre tests_dual.sba_dual.transitive valid_hoare_triple_def)
end
class hoare_calculus_pre_complete = hoare_calculus +
assumes aL_pre_import: "(x«-q)*aL ≤ x«-q*aL"
assumes pre_right_dist_Sum: "x ∈ While_program ∧ ascending_chain t ∧ test_seq t ⟶ x«Sum t = Sum (λn . x«t n)"
begin
lemma aL_pre_import_equal:
"(x«-q)*aL = (x«-q*aL)*aL"
proof -
have 1: "(x«-q)*aL ≤ (x«-q*aL)*aL"
by (smt (z3) aL_pre_import aL_test pre_closed tests_dual.sub_sup_closed tests_dual.least_upper_bound tests_dual.upper_bound_right)
have "(x«-q*aL)*aL ≤ (x«-q)*aL"
by (smt (verit, ccfv_threshold) aL_test pre_closed pre_lower_bound_left tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive tests_dual.sub_sup_closed)
thus ?thesis
using 1 by (smt (z3) tests_dual.antisymmetric aL_test pre_closed tests_dual.sub_sup_closed)
qed
lemma aL_pre_below_t_seq2:
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
shows "(p⋆x«q)*aL ≤ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) 0"
proof (unfold tseq2_def power_zero_id id_def while_pre)
have "(p⋆x«q)*aL = (p*(x«p⋆x«q) ⊔ -p*q)*aL"
by (metis assms while_pre test_pre pre_expression_test)
also have "... = p*(x«p⋆x«q)*aL ⊔ -p*q*aL"
by (smt (z3) assms aL_test tests_dual.sup_right_dist_inf pre_closed pre_expression_test sub_mult_closed test_pre)
also have "... = p*((x«p⋆x«q)*aL) ⊔ -p*q*aL"
by (smt assms aL_test pre_closed pre_expression_test test_pre sub_assoc)
also have "... ≤ p*(x«(p⋆x«q)*aL) ⊔ -p*q"
proof -
have 1: "(x«p⋆x«q)*aL ≤ x«(p⋆x«q)*aL"
by (metis assms(2) pre_closed pre_expression_test aL_pre_import)
have "-p*q*aL ≤ -p*q"
by (metis assms(2) aL_test pre_expression_test tests_dual.sub_sup_closed tests_dual.upper_bound_left)
thus ?thesis
using 1 by (smt assms aL_test pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed tests_dual.sub_sup_right_isotone tests_dual.inf_isotone)
qed
also have "... = -p*q ⊔ p*(x«(p⋆x«q)*aL)"
by (smt assms aL_test tests_dual.inf_commutative pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed)
finally show "(p⋆x«q)*aL ≤ -p*q ⊔ p*(x«(p⋆x«q)*aL)"
.
qed
lemma t_seq2_ascending:
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
and "x ∈ While_program"
shows "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) (Suc m)"
proof (induct m)
let ?w = "p⋆x«q"
let ?r = "-p*q⊔p*(x«?w*aL)"
case 0
have 1: "?w*aL = --(?w*aL)"
by (simp add: assms Pre_expression.conj_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression pre_expression_test)
have 2: "?r = --?r"
by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
have "?w*aL ≤ ?r"
by (metis aL_pre_below_t_seq2 assms(1,2) id_def tseq2_def power_zero_id)
hence "?w*aL ≤ ?w*?r"
using 1 2 by (smt (verit, ccfv_threshold) assms Pre_expression.pre_pre While_program.while_prog aL_test pre_expression_test tests_dual.sub_associative tests_dual.sub_sup_right_isotone tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive)
hence "x«?w*aL ≤ x«(?w*?r)"
by (smt (verit, ccfv_threshold) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre)
hence "p*(x«?w*aL) ≤ p*(x«(?w*?r))"
by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone)
hence "?r ≤ -p*q⊔p*(x«(?w*?r))"
by (smt (verit, del_insts) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone)
thus ?case
by (unfold tseq2_def power_zero_id power_succ_unfold_ext id_def tfun2_def)
next
let ?w = "p⋆x«q"
let ?r = "-p*q⊔p*(x«?w*aL)"
let ?t = "tseq2 (-p*q) p x ?w ?r"
case (Suc m)
hence "?w*?t m ≤ ?w*?t (Suc m)"
by (smt (z3) assms(1,2) pre_closed pre_expression_test t_seq2_test test_expression_test tests_dual.sub_sup_right_isotone)
hence "x«?w*?t m ≤ x«?w*?t (Suc m)"
by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre tseq2_pre_expression)
hence "p*(x«?w*?t m) ≤ p*(x«?w*?t (Suc m))"
by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone tseq2_pre_expression)
hence "-p*q⊔p*(x«?w*?t m) ≤ -p*q⊔p*(x«?w*?t (Suc m))"
by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone tseq2_pre_expression)
thus ?case
by (smt tseq2_def power_succ_unfold_ext tfun2_def)
qed
lemma t_seq2_ascending_chain:
"p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ ascending_chain (tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)))"
by (simp add: ord.ascending_chain_def t_seq2_ascending)
end
class hoare_calculus_complete = hoare_calculus_pre_complete +
assumes while_completeness: "-p*(x«-q) ≤ -q ⟶ -p⋆x«-q ≤ -q⊔aL"
begin
lemma while_completeness_var:
assumes "-p*(x«-q)⊔-r ≤ -q"
shows "-p⋆x«-r ≤ -q⊔aL"
proof -
have 1: "-p⋆x«-q ≤ -q⊔aL"
by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound while_completeness)
have "-p⋆x«-r ≤ -p⋆x«-q"
by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound pre_iso)
thus ?thesis
using 1 by (smt (z3) aL_test pre_closed tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.transitive)
qed
lemma while_completeness_sum:
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
and "x ∈ While_program"
shows "p⋆x«q ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
proof -
let ?w = "p⋆x«q"
let ?r = "-p*q⊔p*(x«?w*aL)"
let ?t = "tseq2 (-p*q) p x ?w ?r"
let ?ts = "tsum2 (-p*q) p x ?w ?r"
have 1: "?w = --?w"
by (metis assms(2) pre_expression_test pre_closed)
have 2: "?r = --?r"
by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
have 3: "?ts = --?ts"
by (meson assms(1) assms(2) pre_expression_test t_sum2_test test_expression_test)
have 4: "test_seq ?t"
by (simp add: assms(1) assms(2) pre_expression_test t_seq2_test_seq test_expression_test)
have "-p*q ≤ ?r"
by (smt (z3) assms(1,2) aL_test pre_closed pre_expression_test sub_mult_closed test_pre tests_dual.lower_bound_left)
hence 5: "-p*q ≤ ?ts"
using 1 2 3 by (smt assms Sum_upper id_def tests_dual.sba_dual.transitive power_zero_id pre_expression_test sub_mult_closed test_pre tseq2_def tseq2_test_seq tsum2_def)
have "∀n . p*(x«?t n) ≤ ?ts"
proof (rule allI, unfold tsum2_def)
fix n
have 6: "p*(x«?t n) ≤ ?t (Suc n)"
using 4 by (smt assms leq_def power_succ_unfold_ext pre_closed pre_expression_test tests_dual.sub_commutative sub_mult_closed t_seq2_below_w test_pre test_seq_def tfun2_def tseq2_def tests_dual.lower_bound_right)
have "?t (Suc n) ≤ Sum ?t"
using 4 Sum_upper by auto
thus "p*(x«?t n) ≤ Sum ?t"
using 3 4 6 by (smt assms(1) pre_closed pre_expression_test sub_mult_closed test_pre test_seq_def tests_dual.transitive tsum2_def)
qed
hence "p*(x«?ts) ≤ ?ts"
using 3 4 by (smt assms mult_left_dist_Sum pre_closed pre_right_dist_Sum t_seq2_ascending_chain test_expression_test test_seq_def tsum2_def)
hence "p*(x«?ts)⊔-p*q ≤ ?ts"
using 3 5 by (smt assms(1,2) tests_dual.greatest_lower_bound pre_closed pre_expression_test sub_mult_closed test_pre)
hence "?w ≤ ?ts⊔aL"
using 1 3 by (smt assms(1,2) pre_expression_test while_post sub_mult_closed t_sum2_below_t_sum t_sum_test test_pre transitive while_completeness_var)
hence "?w = ?w*(?ts⊔aL)"
using 1 3 by (smt aL_test tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.sub_sup_closed)
also have "... = ?w*?ts⊔?w*aL"
using 1 3 by (smt aL_test tests_dual.sup_left_dist_inf)
also have "... ≤ ?ts⊔?t 0"
using 1 3 4 by (smt (z3) assms(1,2) aL_pre_below_t_seq2 tests_dual.upper_bound_right aL_test test_seq_def tests_dual.sub_sup_closed tests_dual.inf_isotone)
also have "... = ?ts"
using 3 4 by (smt Sum_upper tsum2_def test_seq_def tests_dual.less_eq_inf)
finally have "?w ≤ ?ts"
.
thus ?thesis
using 1 3 by (metis assms t_sum2_below_t_sum t_sum2_below_w tests_dual.antisymmetric)
qed
lemma while_complete:
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
and "x ∈ While_program"
and "∀r∈Pre_expression . x«r⦇x⦈r"
shows "p⋆x«q⦇p⋆x⦈q"
proof -
let ?w = "p⋆x«q"
let ?t = "tseq (-p) x ?w (-p⊔(x«?w*aL))"
have 1: "?w ∈ Pre_expression"
by (simp add: assms(1-3) Pre_expression.pre_pre While_program.while_prog)
have 2: "test_seq ?t"
by (simp add: assms(2) pre_expression_test t_seq_test_seq)
hence 3: "?w ≤ Sum ?t"
using assms(1-3) tsum_def while_completeness_sum by auto
have 4: "p = --p"
by (simp add: assms(1) test_expression_test)
have "x«?w*aL = --(x«?w*aL)"
using 1 by (simp add: assms(3) Pre_expression.conj_pre Pre_expression.pre_pre aL_pre_expression pre_expression_test)
hence 5: "(-p⊔(x«?w*aL))*p = (x«?w*aL)*p"
using 4 by (metis tests_dual.sba_dual.inf_complement_intro)
have "x«aL*?w⦇x⦈aL*?w"
using 1 by (simp add: assms(4) Pre_expression.conj_pre aL_pre_expression)
hence "x«?w*aL⦇x⦈aL*?w"
using 1 by (metis aL_test pre_expression_test sub_comm)
hence "(x«?w*aL)*p*?w⦇x⦈aL*?w"
using 1 by (smt (z3) assms(1) Pre_expression.conj_pre Pre_expression.test_pre derived_hoare_triple.cons_trip derived_type pre_expression_test sub_assoc tests_dual.sba_dual.reflexive tests_dual.upper_bound_left)
hence "(-p⊔(x«?w*aL))*p*?w⦇x⦈aL*?w"
using 5 by simp
hence 6: "?t 0*p*?w⦇x⦈aL*?w"
by (unfold tseq_def power_zero_id id_def)
have "∀n>0 . ?t n*p*?w⦇x⦈pSum ?t n*?w"
proof (rule allI, rule impI)
fix n
assume "0<(n::nat)"
from this obtain m where 7: "n = Suc m"
by (auto dest: less_imp_Suc_add)
hence "?t m*?w ≤ pSum ?t n*?w"
using 1 2 by (smt pSum.simps(2) pSum_test pre_expression_test test_seq_def tests_dual.lower_bound_right tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive)
thus "?t n*p*?w⦇x⦈pSum ?t n*?w"
using 1 7 by (smt assms conj_pre cons_trip tests_dual.upper_bound_left tests_dual.sba_dual.inf_complement_intro pSum_pre_expression power_succ_unfold_ext pre_closed pre_expression_test sub_assoc sub_comm t_seq_pre_expression test_pre tfun_def tseq_def)
qed
hence "?w⦇p⋆x⦈-p*?w"
using 1 2 3 6 assms while_trip by auto
hence "?w⦇p⋆x⦈-p*q"
using 4 by (metis assms(2) while_pre_else pre_expression_test while_pre_else)
thus ?thesis
using assms(1,2) Pre_expression.neg_pre Pre_expression.test_pre cons_post_trip by blast
qed
lemma pre_completeness:
"x ∈ While_program ⟹ q ∈ Pre_expression ⟹ x«q⦇x⦈q"
apply (induct arbitrary: q rule: While_program.induct)
apply (simp add: derived_hoare_triple.atom_trip)
apply (metis pre_pre pre_seq seq_trip pre_expression_test)
apply (smt cond_prog cond_trip cons_pre_trip ite_pre_else ite_pre_then neg_pre pre_pre pre_expression_test test_pre)
by (simp add: while_complete)
theorem completeness:
"p⟨x⟩q ⟹ p⦇x⦈q"
by (metis valid_hoare_triple_def pre_completeness tests_dual.reflexive pre_expression_test cons_trip)
end
class hoare_calculus_sound_complete = hoare_calculus_sound + hoare_calculus_complete
begin
text ‹Theorem 41›
theorem soundness_completeness:
"p⦇x⦈q ⟷ p⟨x⟩q"
using completeness soundness by blast
end
class hoare_rules = whiledo + complete_tests + hoare_triple +
assumes rule_pre: "x«-q⦃x⦄-q"
assumes rule_seq: "-p⦃x⦄-q ∧ -q⦃y⦄-r ⟶ -p⦃x*y⦄-r"
assumes rule_cond: "-p*-q⦃x⦄-r ∧ --p*-q⦃y⦄-r ⟶ -q⦃x⊲-p⊳y⦄-r"
assumes rule_while: "test_seq t ∧ -q ≤ Sum t ∧ t 0*-p*-q⦃x⦄aL*-q ∧ (∀n>0 . t n*-p*-q⦃x⦄pSum t n*-q) ⟶ -q⦃-p⋆x⦄--p*-q"
assumes rule_cons: "-p ≤ -q ∧ -q⦃x⦄-r ∧ -r ≤ -s ⟶ -p⦃x⦄-s"
assumes rule_disj: "-p⦃x⦄-r ∧ -q⦃x⦄-s ⟶ -p⊔-q⦃x⦄-r⊔-s"
begin
lemma rule_cons_pre:
"-p ≤ -q ⟹ -q⦃x⦄-r ⟹ -p⦃x⦄-r"
using rule_cons tests_dual.sba_dual.reflexive by blast
lemma rule_cons_pre_mult:
"-q⦃x⦄-r ⟹ -p*-q⦃x⦄-r"
by (metis tests_dual.sub_sup_closed rule_cons_pre tests_dual.upper_bound_right)
lemma rule_cons_pre_plus:
"-p⊔-q⦃x⦄-r ⟹ -p⦃x⦄-r"
by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_pre)
lemma rule_cons_post:
"-q⦃x⦄-r ⟹ -r ≤ -s ⟹ -q⦃x⦄-s"
using rule_cons tests_dual.sba_dual.reflexive by blast
lemma rule_cons_post_mult:
"-q⦃x⦄-r*-s ⟹ -q⦃x⦄-s"
by (metis rule_cons_post tests_dual.upper_bound_left sub_comm sub_mult_closed)
lemma rule_cons_post_plus:
"-q⦃x⦄-r ⟹ -q⦃x⦄-r⊔-s"
by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_post)
lemma rule_disj_pre:
"-p⦃x⦄-r ⟹ -q⦃x⦄-r ⟹ -p⊔-q⦃x⦄-r"
by (metis rule_disj tests_dual.sba_dual.sup_idempotent)
end
class hoare_calculus_valid = hoare_calculus_sound_complete + hoare_triple +
assumes hoare_triple_valid: "-p⦃x⦄-q ⟷ -p ≤ x«-q"
begin
lemma valid_hoare_triple_same:
"p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ p⦃x⦄q = p⟨x⟩q"
by (metis valid_hoare_triple_def hoare_triple_valid pre_expression_test)
lemma derived_hoare_triple_same:
"p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ p⦃x⦄q = p⦇x⦈q"
by (simp add: soundness_completeness valid_hoare_triple_same)
lemma valid_rule_disj:
assumes "-p⦃x⦄-r"
and "-q⦃x⦄-s"
shows "-p⊔-q⦃x⦄-r⊔-s"
proof -
have "x«-r ≤ x«-r⊔-s ∧ x«-s ≤ x«-r⊔-s"
by (metis pre_iso tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left tests_dual.sba_dual.upper_bound_right)
thus ?thesis
by (smt assms hoare_triple_valid tests_dual.greatest_lower_bound tests_dual.sba_dual.sub_sup_closed pre_closed tests_dual.transitive)
qed
subclass hoare_rules
apply unfold_locales
apply (metis hoare_triple_valid pre_closed tests_dual.sba_dual.reflexive)
apply (meson hoare_triple_valid pre_compose)
apply (smt hoare_triple_valid ite_import_mult sub_mult_closed)
apply (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sba_dual.sub_sup_closed sub_mult_closed test_seq_def while_soundness_1)
apply (smt hoare_triple_valid pre_iso tests_dual.transitive pre_closed)
by (simp add: valid_rule_disj)
lemma nat_test_rule_while:
"nat_test t s ⟹ -q ≤ s ⟹ (∀n . t n*-p*-q⦃x⦄pSum t n*-q) ⟹ -q⦃-p⋆x⦄--p*-q"
by (smt (verit, ccfv_threshold) hoare_triple_valid nat_test_def nat_test_pre pSum_test_nat sub_mult_closed)
lemma test_seq_rule_while:
"test_seq t ⟹ -q ≤ Sum t ⟹ t 0*-p*-q⦃x⦄aL*-q ⟹ (∀n>0 . t n*-p*-q⦃x⦄pSum t n*-q) ⟹ -q⦃-p⋆x⦄--p*-q"
by (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sub_mult_closed test_seq_def while_soundness_1)
lemma rule_bot:
"bot⦃x⦄-p"
by (metis hoare_triple_valid pre_closed tests_dual.top_double_complement tests_dual.top_greatest)
lemma rule_skip:
"-p⦃1⦄-p"
by (simp add: hoare_triple_valid pre_one_increasing)
lemma rule_example_4:
assumes "test_seq t"
and "Sum t = 1"
and "t 0*-p1*-p3 = bot"
and "-p1⦃z1⦄-p1*-p2"
and "∀n>0 . t n*-p1*-p2*-p3⦃z2⦄pSum t n*-p1*-p2"
shows "-p1⦃z1*(-p3⋆z2)⦄-p2*--p3"
proof -
have "t 0*-p3*(-p1*-p2) = bot"
by (smt (verit, ccfv_threshold) assms(1,3) sub_assoc sub_comm sub_mult_closed test_seq_def tests_dual.sup_right_zero)
hence 1: "t 0*-p3*(-p1*-p2)⦃z2⦄aL*(-p1*-p2)"
by (metis aL_test sub_mult_closed rule_bot)
have "∀n>0 . t n*-p3*(-p1*-p2)⦃z2⦄pSum t n*(-p1*-p2)"
by (smt assms(1,5) lower_bound_left pSum_test rule_cons_pre sub_assoc sub_comm sub_mult_closed test_seq_def)
hence "-p1*-p2⦃-p3⋆z2⦄--p3*(-p1*-p2)"
using 1 by (smt (verit, del_insts) assms(1,2) tests_dual.sub_bot_least rule_while sub_mult_closed)
thus ?thesis
by (smt assms(4) tests_dual.upper_bound_left rule_cons_post rule_seq sub_assoc sub_comm sub_mult_closed)
qed
end
class hoare_calculus_pc_2 = hoare_calculus_sound + hoare_calculus_pre_complete +
assumes aL_one: "aL = 1"
begin
subclass hoare_calculus_sound_complete
apply unfold_locales
by (simp add: aL_one pre_below_one)
lemma while_soundness_pc:
assumes "-p*-q ≤ x«-q"
shows "-q ≤ -p⋆x«--p*-q"
proof -
let ?t = "λx . 1"
have 1: "test_seq ?t"
by (simp add: test_seq_def)
hence 2: "-q ≤ Sum ?t"
by (metis Sum_test Sum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least)
have 3: "?t 0*-p*-q ≤ x«aL*-q"
using 1 by (simp add: assms aL_one)
have "∀n>0 . ?t n*-p*-q ≤ x«pSum ?t n*-q"
using 1 by (metis assms pSum_test pSum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least tests_dual.sup_left_unit)
thus ?thesis
using 1 2 3 aL_one while_soundness_0 by auto
qed
end
class hoare_calculus_pc = hoare_calculus_sound + hoare_calculus_pre_complete +
assumes pre_one_one: "x«1 = 1"
begin
subclass hoare_calculus_pc_2
apply unfold_locales
by (simp add: aL_def pre_one_one)
end
class hoare_calculus_pc_valid = hoare_calculus_pc + hoare_calculus_valid
begin
lemma rule_while_pc:
"-p*-q⦃x⦄-q ⟹ -q⦃-p⋆x⦄--p*-q"
by (metis hoare_triple_valid sub_mult_closed while_soundness_pc)
lemma rule_alternation:
"-p⦃x⦄-q ⟹ -q⦃y⦄-p ⟹ -p⦃-r⋆x*y⦄--r*-p"
by (meson rule_cons_pre_mult rule_seq rule_while_pc)
lemma rule_alternation_context:
"-p⦃v⦄-p ⟹ -p⦃w⦄-q ⟹ -q⦃x⦄-q ⟹ -q⦃y⦄-p ∧ -p⦃z⦄-p ⟹ -p⦃-r⋆v*w*x*y*z⦄--r*-p"
by (meson rule_cons_pre_mult rule_seq rule_while_pc)
lemma rule_example_3:
assumes "-p*-q⦃x⦄--p*-q"
and "--p*-r⦃x⦄-p*-r"
and "-p*-r⦃y⦄-p*-q"
and "--p*-q⦃z⦄--p*-r"
shows "-p*-q⊔--p*-r⦃-s⋆x*(y⊲-p⊳z)⦄--s*(-p*-q⊔--p*-r)"
proof -
have t1: "-p*-q⊔--p*-r⦃x⦄--p*-q⊔-p*-r"
by (smt assms(1,2) rule_disj sub_mult_closed)
have "-p*-r⦃y⦄-p*-q⊔--p*-r"
by (smt assms(3) rule_cons_post_plus sub_mult_closed)
hence t2: "-p*(--p*-q⊔-p*-r)⦃y⦄-p*-q⊔--p*-r"
by (smt (z3) tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_sup_closed tests_dual.upper_bound_left tests_dual.wnf_lemma_3)
have "--p*-q⦃z⦄-p*-q⊔--p*-r"
by (smt assms(4) tests_dual.inf_commutative rule_cons_post_plus sub_mult_closed)
hence "--p*(--p*-q⊔-p*-r)⦃z⦄-p*-q⊔--p*-r"
by (smt (z3) tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_absorb tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_complement_intro tests_dual.sup_left_dist_inf tests_dual.sup_right_unit tests_dual.top_double_complement)
hence "--p*-q⊔-p*-r⦃y⊲-p⊳z⦄-p*-q⊔--p*-r"
using t2 by (smt tests_dual.inf_closed rule_cond sub_mult_closed)
hence "-s*(-p*-q⊔--p*-r)⦃x*(y⊲-p⊳z)⦄-p*-q⊔--p*-r"
using t1 by (smt tests_dual.inf_closed rule_cons_pre_mult rule_seq sub_mult_closed)
thus ?thesis
by (smt tests_dual.inf_closed rule_while_pc sub_mult_closed)
qed
end
class hoare_calculus_tc = hoare_calculus + precondition_test_test + precondition_distr_mult +
assumes while_bnd: "p ∈ Test_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program ⟶ p⋆x«q ≤ Sum (λn . (p*x)^n«bot)"
begin
lemma
assumes "p ∈ Test_expression"
and "q ∈ Pre_expression"
and "x ∈ While_program"
shows "p⋆x«q ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
proof -
let ?w = "p⋆x«q"
let ?s = "-p⊔(x«?w*aL)"
let ?t = "tseq (-p) x ?w ?s"
let ?b = "λn . (p*x)^n«bot"
have 2: "test_seq ?t"
by (simp add: assms(2) pre_expression_test t_seq_test_seq)
have 3: "test_seq ?b"
using pre_closed test_seq_def tests_dual.sba_dual.complement_top by blast
have 4: "?w = --?w"
by (metis assms(2) pre_expression_test pre_closed)
have "?w ≤ Sum ?b"
using assms while_bnd by blast
hence 5: "?w = Sum ?b*?w"
using 3 4 by (smt Sum_test leq_def sub_comm)
have "∀n . ?b n*?w ≤ ?t n"
proof
fix n
show "?b n*?w ≤ ?t n"
proof (induct n)
show "?b 0*?w ≤ ?t 0"
using 2 4 by (metis power.power_0 pre_one test_seq_def tests_dual.sup_left_zero tests_dual.top_double_complement tests_dual.top_greatest)
next
fix n
assume 6: "?b n*?w ≤ ?t n"
have "-p ≤ ?t (Suc n)"
apply (unfold tseq_def power_succ_unfold_ext)
by (smt assms(2) pre_expression_test t_seq_test pre_closed sub_mult_closed tfun_def tseq_def tests_dual.lower_bound_left)
hence 7: "-p*?b (Suc n)*?w ≤ ?t (Suc n)"
using 2 3 4 by (smt tests_dual.upper_bound_left sub_mult_closed test_seq_def tests_dual.transitive)
have 8: "p*?b (Suc n)*?w ≤ x«?w*(?b n*?w)"
by (smt assms(1,2) tests_dual.upper_bound_right tests_dual.sup_idempotent power_Suc pre_closed pre_distr_mult pre_expression_test pre_import_composition sub_assoc sub_comm sub_mult_closed test_expression_test while_pre_then tests_dual.top_double_complement)
have 9: "... ≤ x«?w*?t n"
using 2 3 4 6 by (smt tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed test_seq_def)
have "... ≤ ?t (Suc n)"
using 2 4 by (smt power_succ_unfold_ext pre_closed sub_mult_closed test_seq_def tfun_def tseq_def tests_dual.lower_bound_right)
hence "p*?b (Suc n)*?w ≤ ?t (Suc n)"
using 2 3 4 8 9 by (smt assms(1) pre_closed sub_mult_closed test_expression_test test_seq_def tests_dual.transitive)
thus "?b (Suc n)*?w ≤ ?t (Suc n)"
using 2 3 4 7 by (smt assms(1) tests_dual.sup_less_eq_cases sub_assoc sub_mult_closed test_expression_test test_seq_def)
qed
qed
hence "Sum ?b*?w ≤ tsum (-p) x ?w ?s"
using 3 4 by (smt assms(2) Sum_upper mult_right_dist_Sum pre_expression_test sub_mult_closed t_seq_test t_sum_test test_seq_def tests_dual.transitive tsum_def)
thus ?thesis
using 5 by auto
qed
end
class complete_pre = complete_tests + precondition + power
begin
definition bnd :: "'a ⇒ 'a"
where "bnd x ≡ Sup { x^n«bot | n::nat . True }"
lemma bnd_test_set:
"test_set { x^n«bot | n::nat . True }"
by (smt (verit, del_insts) CollectD pre_closed test_set_def tests_dual.top_double_complement)
lemma bnd_test:
"bnd x = --bnd x"
using bnd_def bnd_test_set sup_test by auto
lemma bnd_upper:
"x^m«bot ≤ bnd x"
proof -
have "x^m«bot ∈ { x^m«bot | m::nat . True }"
by auto
thus ?thesis
using bnd_def bnd_test_set sup_upper by auto
qed
lemma bnd_least:
assumes "∀n . x^n«bot ≤ -p"
shows "bnd x ≤ -p"
proof -
have "∀y∈{ x^n«bot | n::nat . True } . y ≤ -p"
using assms by blast
thus ?thesis
using bnd_def bnd_test_set sup_least by auto
qed
lemma mult_right_dist_bnd:
assumes "∀n . (x^n«bot)*-p ≤ -q"
shows "bnd x*-p ≤ -q"
proof -
have "Sup { y*-p | y . y ∈ { x^n«bot | n::nat . True } } ≤ -q"
by (smt assms mem_Collect_eq tests_dual.complement_bot pre_closed sub_mult_closed sup_least test_set_def)
thus ?thesis
using bnd_test_set bnd_def mult_right_dist_sup by simp
qed
lemma tests_complete:
"nat_test (λn . (-p*x)^n«bot) (bnd(-p*x))"
using bnd_test bnd_upper mult_right_dist_bnd nat_test_def tests_dual.complement_bot pre_closed by blast
end
end
Theory Hoare_Modal
section ‹Hoare Calculus and Modal Operators›
theory Hoare_Modal
imports Stone_Kleene_Relation_Algebras.Kleene_Algebras Complete_Domain Hoare Relative_Modal
begin
class box_precondition = relative_box_semiring + pre +
assumes pre_def: "x«p = |x]p"
begin
text ‹Theorem 47›
subclass precondition
apply unfold_locales
apply (simp add: box_x_a pre_def)
apply (simp add: box_left_mult pre_def)
using box_def box_right_submult_a_a pre_def tests_dual.sba_dual.greatest_lower_bound apply fastforce
by (simp add: box_1_a pre_def)
subclass precondition_test_test
apply unfold_locales
by (simp add: a_box_a_a pre_def)
subclass precondition_promote
apply unfold_locales
using a_mult_d box_def pre_def pre_test_test by auto
subclass precondition_test_box
apply unfold_locales
by (simp add: box_a_a d_def pre_def)
lemma pre_Z:
"-p ≤ x«-q ⟷ -p * x * --q ≤ Z"
by (simp add: box_demodalisation_2 pre_def)
lemma pre_left_dist_add:
"x⊔y«-q = (x«-q) * (y«-q)"
by (simp add: box_left_dist_sup pre_def)
lemma pre_left_antitone:
"x ≤ y ⟹ y«-q ≤ x«-q"
by (simp add: box_antitone_isotone pre_def)
lemma pre_promote_neg:
"(x«-q) * x * --q ≤ Z"
by (simp add: box_below_Z pre_def)
lemma pre_pc_Z:
"x«1 = 1 ⟷ x * bot ≤ Z"
by (simp add: a_strict box_x_1 pre_def)
end
class left_zero_box_precondition = box_precondition + relative_left_zero_antidomain_semiring
begin
lemma pre_sub_promote:
"(x«-q) * x ≤ (x«-q) * x * -q ⊔ Z"
using case_split_right_sup pre_promote_neg by blast
lemma pre_promote:
"(x«-q) * x ⊔ Z = (x«-q) * x * -q ⊔ Z"
apply (rule sup_same_context)
apply (simp add: pre_sub_promote)
by (metis a_below_one le_supI1 mult_1_right mult_right_isotone)
lemma pre_mult_sub_promote:
"(x*y«-q) * x ≤ (x*y«-q) * x * (y«-q) ⊔ Z"
by (metis pre_closed pre_seq pre_sub_promote)
lemma pre_mult_promote_sub:
"(x*y«-q) * x * (y«-q) ≤ (x*y«-q) * x"
by (metis mult_right_isotone mult_1_right pre_below_one)
lemma pre_mult_promote:
"(x*y«-q) * x * (y«-q) ⊔ Z = (x*y«-q) * x ⊔ Z"
by (metis sup_ge1 sup_same_context order_trans pre_mult_sub_promote pre_mult_promote_sub)
end
class diamond_precondition = relative_box_semiring + pre +
assumes pre_def: "x«p = |x>p"
begin
text ‹Theorem 47›
subclass precondition
apply unfold_locales
apply (simp add: d_def diamond_def pre_def)
apply (simp add: diamond_left_mult pre_def)
apply (metis a_antitone a_dist_sup box_antitone_isotone box_deMorgan_1 order.refl pre_def sup_right_divisibility)
by (simp add: diamond_1_a pre_def)
subclass precondition_test_test
apply unfold_locales
by (metis diamond_a_a_same diamond_a_export diamond_associative diamond_right_mult pre_def)
subclass precondition_promote
apply unfold_locales
using d_def diamond_def pre_def pre_test_test tests_dual.sub_sup_closed by force
subclass precondition_test_diamond
apply unfold_locales
by (simp add: diamond_a_a pre_def)
lemma pre_left_dist_add:
"x⊔y«-q = (x«-q) ⊔ (y«-q)"
by (simp add: diamond_left_dist_sup pre_def)
lemma pre_left_isotone:
"x ≤ y ⟹ x«-q ≤ y«-q"
by (metis diamond_left_isotone pre_def)
end
class box_while = box_precondition + bounded_left_conway_semiring + ite + while +
assumes ite_def: "x⊲p⊳y = p * x ⊔ -p * y"
assumes while_def: "p⋆x = (p * x)⇧∘ * -p"
begin
subclass bounded_relative_antidomain_semiring ..
lemma Z_circ_left_zero:
"Z * x⇧∘ = Z"
using Z_left_zero_above_one circ_plus_one sup.absorb_iff2 by auto
subclass ifthenelse
apply unfold_locales
by (smt a_d_closed box_a_export box_left_dist_sup box_x_a tests_dual.case_duality d_def ite_def pre_def)
text ‹Theorem 48.1›
subclass whiledo
apply unfold_locales
apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
using pre_mult_test_promote while_def by auto
lemma pre_while_1:
"-p*(-p⋆x)«1 = -p⋆x«1"
proof -
have "--p*(-p*(-p⋆x)«1) = --p*(-p⋆x«1)"
by (metis mult_1_right pre_closed pre_seq pre_test_neg tests_dual.sba_dual.top_double_complement while_pre_else)
thus ?thesis
by (smt (z3) pre_closed pre_import tests_dual.sba_dual.top_double_complement tests_dual.sup_eq_cases)
qed
lemma aL_one_circ:
"aL = a(1⇧∘*bot)"
by (metis aL_def box_left_mult box_x_a idempotent_bot_closed idempotent_one_closed pre_def tests_dual.sba_dual.one_def while_def tests_dual.one_def)
end
class diamond_while = diamond_precondition + bounded_left_conway_semiring + ite + while +
assumes ite_def: "x⊲p⊳y = p * x ⊔ -p * y"
assumes while_def: "p⋆x = (p * x)⇧∘ * -p"
begin
subclass bounded_relative_antidomain_semiring ..
lemma Z_circ_left_zero:
"Z * x⇧∘ = Z"
by (simp add: Z_left_zero_above_one circ_reflexive)
subclass ifthenelse
apply unfold_locales
by (simp add: ite_def pre_export pre_left_dist_add)
text ‹Theorem 48.2›
subclass whiledo
apply unfold_locales
apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
by (simp add: pre_mult_test_promote while_def)
lemma aL_one_circ:
"aL = d(1⇧∘*bot)"
by (metis aL_def tests_dual.complement_bot diamond_x_1 mult_left_one pre_def while_def)
end
class box_while_program = box_while + atoms
begin
subclass while_program ..
end
class diamond_while_program = diamond_while + atoms
begin
subclass while_program ..
end
class box_hoare_calculus = box_while_program + complete_antidomain_semiring
begin
subclass hoare_calculus ..
end
class diamond_hoare_calculus = diamond_while_program + complete_antidomain_semiring
begin
subclass hoare_calculus ..
end
class box_hoare_sound = box_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
assumes aL_circ: "aL * x⇧∘ ≤ x⇧⋆"
begin
lemma aL_circ_ext:
"|x⇧⋆]y ≤ |aL * x⇧∘]y"
by (simp add: aL_circ box_left_antitone)
lemma box_star_induct:
assumes "-p ≤ |x](-p)"
shows "-p ≤ |x⇧⋆](-p)"
proof -
have 1: "x*--p*top ≤ Z ⊔ --p*top"
by (metis assms Z_top sup_commute box_demodalisation_2 mult_assoc mult_left_isotone shunting_Z)
have "x*(Z ⊔ --p*top) ≤ x*--p*top ⊔ Z"
using split_Z sup_monoid.add_commute mult_assoc by force
also have "... ≤ Z ⊔ --p*top"
using 1 by simp
finally have "x*(Z ⊔ --p*top) ⊔ --p ≤ Z ⊔ --p*top"
using le_supI2 sup.bounded_iff top_right_mult_increasing by auto
thus ?thesis
by (metis sup_commute box_demodalisation_2 mult_assoc shunting_Z star_left_induct)
qed
lemma box_circ_induct:
"-p ≤ |x](-p) ⟹ -p*aL ≤ |x⇧∘](-p)"
by (smt aL_circ_ext aL_test box_left_mult box_star_induct order_trans tests_dual.inf_commutative pre_closed pre_def pre_test tests_dual.shunting_right)
lemma a_while_soundness:
assumes "-p*-q ≤ |x](-q)"
shows "aL*-q ≤ |(-p*x)⇧∘*--p](-q)"
proof -
have "|(-p*x)⇧∘](-q) ≤ |(-p*x)⇧∘*--p](-q)"
by (meson box_left_antitone circ_mult_upper_bound circ_reflexive order.refl order.trans tests_dual.sub_bot_least)
thus ?thesis
by (smt assms box_import_shunting box_circ_induct order_trans sub_comm aL_test)
qed
subclass hoare_calculus_sound
apply unfold_locales
by (simp add: a_while_soundness pre_def while_def)
end
class diamond_hoare_sound = diamond_hoare_calculus + left_kleene_conway_semiring +
assumes aL_circ: "aL * x⇧∘ ≤ x⇧⋆"
begin
lemma aL_circ_equal:
"aL * x⇧∘ = aL * x⇧⋆"
apply (rule order.antisym)
using aL_circ aL_one_circ d_restrict_iff_1 apply force
by (simp add: mult_right_isotone star_below_circ)
lemma aL_zero:
"aL = bot"
by (smt aL_circ_equal aL_one_circ d_export d_idempotent diamond_d_bot diamond_def mult_assoc mult_1_right star_one)
subclass hoare_calculus_sound
apply unfold_locales
using aL_zero by auto
end
class box_hoare_complete = box_hoare_calculus + left_kleene_conway_semiring +
assumes box_circ_induct_2: "-p*|x](-q) ≤ -q ⟶ |x⇧∘](-p) ≤ -q⊔aL"
assumes aL_zero_or_one: "aL = bot ∨ aL = 1"
assumes while_mult_left_dist_Prod: "x ∈ While_program ∧ descending_chain t ∧ test_seq t ⟶ x*Prod t = Prod (λn . x*t n)"
begin
subclass hoare_calculus_complete
apply unfold_locales
apply (metis aL_zero_or_one bot_least order.eq_iff mult_1_right pre_closed tests_dual.sup_right_zero)
subgoal
apply (unfold pre_def box_def)
by (metis a_ascending_chain a_dist_Prod a_dist_Sum descending_chain_left_mult while_mult_left_dist_Prod test_seq_def)
by (smt box_circ_induct_2 tests_dual.double_negation tests_dual.greatest_lower_bound tests_dual.upper_bound_left mult_right_dist_sup pre_closed pre_def pre_import pre_seq pre_test sub_mult_closed while_def)
end
class diamond_hoare_complete = diamond_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
assumes dL_circ: "-aL*x⇧∘ ≤ x⇧⋆"
assumes aL_zero_or_one: "aL = bot ∨ aL = 1"
assumes while_mult_left_dist_Sum: "x ∈ While_program ∧ ascending_chain t ∧ test_seq t ⟶ x*Sum t = Sum (λn . x*t n)"
begin
lemma diamond_star_induct_var:
assumes "|x>(d p) ≤ d p"
shows "|x⇧⋆>(d p) ≤ d p"
proof -
have "x * (d p * x⇧⋆ ⊔ Z) ≤ d p * x * x⇧⋆ ⊔ Z * x⇧⋆ ⊔ Z"
by (metis assms sup_left_isotone d_mult_d diamond_def diamond_demodalisation_3 mult_assoc mult_left_isotone mult_right_dist_sup order_trans split_Z)
also have "... ≤ d p * x⇧⋆ ⊔ Z"
by (metis Z_mult_decreasing mult_right_isotone star.left_plus_below_circ sup.bounded_iff sup_ge1 sup_mono sup_monoid.add_commute mult_assoc)
finally show ?thesis
by (smt sup_commute le_sup_iff sup_ge2 d_mult_d diamond_def diamond_demodalisation_3 order_trans star.circ_back_loop_prefixpoint star_left_induct)
qed
lemma diamond_star_induct:
"d q ⊔ |x>(d p) ≤ d p ⟹ |x⇧⋆>(d q) ≤ d p"
by (metis le_sup_iff diamond_star_induct_var diamond_right_isotone order_trans)
lemma while_completeness_1:
assumes "-p*(x«-q) ≤ -q"
shows "-p⋆x«-q ≤ -q⊔aL"
proof -
have "--p*-q ⊔ |-p*x>(-q) ≤ -q"
using assms pre_def pre_export tests_dual.upper_bound_right by auto
hence "|(-p*x)⇧⋆>(--p*-q) ≤ -q"
by (smt diamond_star_induct d_def sub_mult_closed tests_dual.double_negation)
hence "|-aL*(-p*x)⇧∘>(--p*-q) ≤ -q"
by (meson dL_circ diamond_isotone order.eq_iff order.trans)
thus ?thesis
by (smt aL_test diamond_a_export diamond_def mult_assoc tests_dual.inf_commutative pre_closed pre_def tests_dual.shunting while_def)
qed
subclass hoare_calculus_complete
apply unfold_locales
apply (metis aL_test aL_zero_or_one bot_least order.eq_iff pre_closed pre_test pre_test_one tests_dual.sup_right_zero)
subgoal
apply (unfold pre_def diamond_def)
by (simp add: ascending_chain_left_mult d_dist_Sum while_mult_left_dist_Sum)
by (simp add: while_completeness_1)
end
class box_hoare_valid = box_hoare_sound + box_hoare_complete + hoare_triple +
assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x]q"
begin
text ‹Theorem 49.2›
subclass hoare_calculus_valid
apply unfold_locales
by (simp add: hoare_triple_def pre_def)
lemma rule_skip_valid:
"-p⦃1⦄-p"
by (simp add: rule_skip)
end
class diamond_hoare_valid = diamond_hoare_sound + diamond_hoare_complete + hoare_triple +
assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x>q"
begin
lemma circ_star_equal:
"x⇧∘ = x⇧⋆"
by (metis aL_zero order.antisym dL_circ mult_left_one one_def star_below_circ)
text ‹Theorem 49.1›
subclass hoare_calculus_valid
apply unfold_locales
by (simp add: hoare_triple_def pre_def)
end
class diamond_hoare_sound_2 = diamond_hoare_calculus + left_kleene_conway_semiring +
assumes diamond_circ_induct_2: "--p*-q ≤ |x>(-q) ⟶ aL*-q ≤ |x⇧∘>(-p)"
begin
subclass hoare_calculus_sound
apply unfold_locales
by (smt a_export diamond_associative diamond_circ_induct_2 tests_dual.double_negation tests_dual.sup_complement_intro pre_def pre_import_equiv_mult sub_comm sub_mult_closed while_def)
end
class diamond_hoare_valid_2 = diamond_hoare_sound_2 + diamond_hoare_complete + hoare_triple +
assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x>q"
begin
subclass hoare_calculus_valid
apply unfold_locales
by (simp add: hoare_triple_def pre_def)
end
end
Theory Pre_Post
section ‹Pre-Post Specifications›
theory Pre_Post
imports Preconditions
begin
class pre_post =
fixes pre_post :: "'a ⇒ 'a ⇒ 'a" (infix "⊣" 55)
class pre_post_spec_greatest = bounded_idempotent_left_semiring + precondition + pre_post +
assumes pre_post_galois: "-p ≤ x«-q ⟷ x ≤ -p⊣-q"
begin
text ‹Theorem 42.1›
lemma post_pre_left_antitone:
"x ≤ y ⟹ y«-q ≤ x«-q"
by (smt order_refl order_trans pre_closed pre_post_galois)
lemma pre_left_sub_dist:
"x⊔y«-q ≤ x«-q"
by (simp add: post_pre_left_antitone)
text ‹Theorem 42.2›
lemma pre_post_left_antitone:
"-p ≤ -q ⟹ -q⊣-r ≤ -p⊣-r"
using order_lesseq_imp pre_post_galois by blast
lemma pre_post_left_sub_dist:
"-p⊔-q⊣-r ≤ -p⊣-r"
by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_left_antitone)
lemma pre_post_left_sup_dist:
"-p⊣-r ≤ -p*-q⊣-r"
by (metis tests_dual.sba_dual.sub_inf_def pre_post_left_sub_dist tests_dual.inf_absorb)
text ‹Theorem 42.5›
lemma pre_pre_post:
"x ≤ (x«-p)⊣-p"
by (metis order_refl pre_closed pre_post_galois)
text ‹Theorem 42.6›
lemma pre_post_pre:
"-p ≤ (-p⊣-q)«-q"
by (simp add: pre_post_galois)
text ‹Theorem 42.8›
lemma pre_post_zero_top:
"bot⊣-q = top"
by (metis order.eq_iff pre_post_galois sup.cobounded2 sup_monoid.add_0_right top_greatest tests_dual.top_double_complement)
text ‹Theorem 42.7›
lemma pre_post_pre_one:
"(1⊣-q)«-q = 1"
by (metis order.eq_iff pre_below_one tests_dual.sba_dual.top_double_complement pre_post_pre)
text ‹Theorem 42.3›
lemma pre_post_right_isotone:
"-p ≤ -q ⟹ -r⊣-p ≤ -r⊣-q"
using order_lesseq_imp pre_iso pre_post_galois by blast
lemma pre_post_right_sub_dist:
"-r⊣-p ≤ -r⊣-p⊔-q"
by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_right_isotone)
lemma pre_post_right_sup_dist:
"-r⊣-p*-q ≤ -r⊣-p"
by (metis tests_dual.sub_sup_closed pre_post_right_isotone tests_dual.upper_bound_left)
text ‹Theorem 42.7›
lemma pre_post_reflexive:
"1 ≤ -p⊣-p"
using pre_one_increasing pre_post_galois by auto
text ‹Theorem 42.9›
lemma pre_post_compose:
"-q ≤ -r ⟹ (-p⊣-q)*(-r⊣-s) ≤ -p⊣-s"
using order_lesseq_imp pre_compose pre_post_galois by blast
text ‹Theorem 42.10›
lemma pre_post_compose_1:
"(-p⊣-q)*(-q⊣-r) ≤ -p⊣-r"
by (simp add: pre_post_compose)
text ‹Theorem 42.11›
lemma pre_post_compose_2:
"(-p⊣-p)*(-p⊣-q) = -p⊣-q"
by (meson case_split_left order.eq_iff le_supI1 pre_post_compose_1 pre_post_reflexive)
text ‹Theorem 42.12›
lemma pre_post_compose_3:
"(-p⊣-q)*(-q⊣-q) = -p⊣-q"
by (meson order.eq_iff order.trans mult_right_isotone mult_sub_right_one pre_post_compose_1 pre_post_reflexive)
text ‹Theorem 42.13›
lemma pre_post_compose_4:
"(-p⊣-p)*(-p⊣-p) = -p⊣-p"
by (simp add: pre_post_compose_3)
text ‹Theorem 42.14›
lemma pre_post_one_one:
"x«1 = 1 ⟷ x ≤ 1⊣1"
by (metis order.eq_iff one_def pre_below_one pre_post_galois)
text ‹Theorem 42.4›
lemma post_pre_left_dist_sup:
"x⊔y«-q = (x«-q)*(y«-q)"
apply (rule order.antisym)
apply (metis mult_isotone pre_closed sup_commute tests_dual.sup_idempotent pre_left_sub_dist)
by (smt (z3) order.refl pre_closed pre_post_galois sup.boundedI tests_dual.sba_dual.greatest_lower_bound tests_dual.sub_sup_closed)
end
class pre_post_spec_greatest_2 = pre_post_spec_greatest + precondition_test_test
begin
subclass precondition_test_box
apply unfold_locales
by (smt (verit) sup_commute mult_1_right tests_dual.double_negation order.eq_iff mult_left_one mult_right_dist_sup one_def tests_dual.inf_complement tests_dual.inf_complement_intro pre_below_one pre_import pre_post_galois pre_test_test tests_dual.top_def bot_least)
lemma pre_post_seq_sub_associative:
"(-p⊣-q)*-r ≤ -p⊣-q*-r"
by (smt (z3) pre_compose pre_post_galois pre_post_pre sub_comm test_below_pre_test_mult tests_dual.sub_sup_closed)
lemma pre_post_right_import_mult:
"(-p⊣-q)*-r = (-p⊣-q*-r)*-r"
by (metis order.antisym mult_assoc tests_dual.sup_idempotent mult_left_isotone pre_post_right_sup_dist pre_post_seq_sub_associative)
lemma seq_pre_post_sub_associative:
"-r*(-p⊣-q) ≤ --r⊔-p⊣-q"
by (smt (z3) pre_compose pre_post_galois pre_post_pre pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed)
lemma pre_post_left_import_sup:
"-r*(-p⊣-q) = -r*(--r⊔-p⊣-q)"
by (metis sup_commute order.antisym mult_assoc tests_dual.sup_idempotent mult_right_isotone pre_post_left_sub_dist seq_pre_post_sub_associative)
lemma pre_post_import_same:
"-p*(-p⊣-q) = -p*(1⊣-q)"
using pre_test pre_test_test_same pre_post_left_import_sup by auto
lemma pre_post_import_complement:
"--p*(-p⊣-q) = --p*top"
by (metis tests_dual.sup_idempotent tests_dual.inf_cases tests_dual.inf_closed pre_post_left_import_sup pre_post_zero_top tests_dual.top_def tests_dual.top_double_complement)
lemma pre_post_export:
"-p⊣-q = (1⊣-q) ⊔ --p*top"
proof (rule order.antisym)
have 1: "-p*(-p⊣-q) ≤ (1⊣-q) ⊔ --p*top"
by (metis le_supI1 pre_test pre_test_test_same seq_pre_post_sub_associative)
have "--p*(-p⊣-q) ≤ (1⊣-q) ⊔ --p*top"
by (simp add: pre_post_import_complement)
thus "-p⊣-q ≤ (1⊣-q) ⊔ --p*top"
using 1 by (smt case_split_left eq_refl tests_dual.inf_complement)
next
show "(1⊣-q) ⊔ --p*top ≤ -p⊣-q"
by (metis le_sup_iff tests_dual.double_negation tests_dual.sub_bot_least pre_neg_mult pre_post_galois pre_post_pre_one)
qed
lemma pre_post_left_dist_mult:
"-p*-q⊣-r = (-p⊣-r) ⊔ (-q⊣-r)"
proof -
have "∀p q . -p*(-p*-q⊣-r) = -p*(-q⊣-r)"
using sup_monoid.add_commute tests_dual.sba_dual.sub_inf_def pre_post_left_import_sup tests_dual.inf_complement_intro by auto
hence 1: "(-p⊔-q)*(-p*-q⊣-r) ≤ (-p⊣-r) ⊔ (-q⊣-r)"
by (metis sup_commute le_sup_iff sup_ge2 mult_left_one mult_right_dist_sup tests_dual.inf_left_unit sub_comm)
have "-(-p⊔-q)*(-p*-q⊣-r) = -(-p⊔-q)*top"
by (smt (z3) sup.left_commute sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed pre_post_import_complement pre_post_left_import_sup tests_dual.inf_absorb)
hence "-(-p⊔-q)*(-p*-q⊣-r) ≤ (-p⊣-r) ⊔ (-q⊣-r)"
by (smt (z3) order.trans le_supI1 pre_post_left_sub_dist tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed seq_pre_post_sub_associative)
thus ?thesis
using 1 by (smt (z3) le_sup_iff order.antisym case_split_left order_refl tests_dual.inf_closed tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
qed
lemma pre_post_left_import_mult:
"-r*(-p⊣-q) = -r*(-r*-p⊣-q)"
by (metis sup_commute tests_dual.inf_complement_intro pre_post_left_import_sup sub_mult_closed)
lemma pre_post_right_import_sup:
"(-p⊣-q)*-r = (-p⊣-q⊔--r)*-r"
by (smt (z3) sup_monoid.add_commute tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.inf_complement_intro tests_dual.sub_complement tests_dual.sub_inf_def pre_post_right_import_mult)
lemma pre_post_shunting:
"x ≤ -p*-q⊣-r ⟷ -p*x ≤ -q⊣-r"
proof -
have "--p*x ≤ -p*-q⊣-r"
by (metis tests_dual.double_negation order_trans pre_neg_mult pre_post_galois pre_post_left_sup_dist)
hence 1: "-p*x ≤ -q⊣-r ⟶ x ≤ -p*-q⊣-r"
by (smt case_split_left eq_refl order_trans tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
have "-p*(-p*-q⊣-r) ≤ -q⊣-r"
by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least pre_post_left_import_mult)
thus ?thesis
using 1 mult_right_isotone order_lesseq_imp by blast
qed
end
class left_zero_pre_post_spec_greatest_2 = pre_post_spec_greatest_2 + bounded_idempotent_left_zero_semiring
begin
lemma pre_post_right_dist_sup:
"-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)"
proof -
have 1: "(-p⊣-q⊔-r)*-q ≤ (-p⊣-q) ⊔ (-p⊣-r)"
by (metis le_supI1 pre_post_seq_sub_associative tests_dual.sba_dual.inf_absorb tests_dual.sba_dual.sub_sup_closed)
have "(-p⊣-q⊔-r)*--q = (-p⊣-r)*--q"
by (simp add: pre_post_right_import_sup sup_commute)
hence "(-p⊣-q⊔-r)*--q ≤ (-p⊣-q) ⊔ (-p⊣-r)"
by (metis sup_ge2 mult_left_sub_dist_sup_right mult_1_right order_trans tests_dual.inf_left_unit)
thus ?thesis
using 1 by (metis le_sup_iff order.antisym case_split_right tests_dual.sub_bot_least tests_dual.inf_commutative tests_dual.inf_complement pre_post_right_sub_dist)
qed
end
class havoc =
fixes H :: "'a"
class idempotent_left_semiring_H = bounded_idempotent_left_semiring + havoc +
assumes H_zero : "H * bot = bot"
assumes H_split: "x ≤ x * bot ⊔ H"
begin
lemma H_galois:
"x * bot ≤ y ⟷ x ≤ y ⊔ H"
apply (rule iffI)
using H_split order_lesseq_imp sup_mono apply blast
by (smt (verit, ccfv_threshold) H_zero mult_right_dist_sup sup.cobounded2 sup.orderE sup_assoc sup_bot_left sup_commute zero_right_mult_decreasing)
lemma H_greatest_finite:
"x * bot = bot ⟷ x ≤ H"
by (metis H_galois le_iff_sup sup_bot_left sup_monoid.add_0_right)
lemma H_reflexive:
"1 ≤ H"
using H_greatest_finite mult_left_one by blast
lemma H_transitive:
"H = H * H"
by (metis H_greatest_finite H_reflexive H_zero preorder_idempotent mult_assoc)
lemma T_split_H:
"top * bot ⊔ H = top"
by (simp add: H_split order.antisym)
end
class pre_post_spec_least = bounded_idempotent_left_semiring + precondition_test_test + precondition_promote + pre_post +
assumes test_mult_right_distr_sup: "-p * (x ⊔ y) = -p * x ⊔ -p * y"
assumes pre_post_galois: "-p ≤ x«-q ⟷ -p⊣-q ≤ x"
begin
lemma shunting_top:
"-p * x ≤ y ⟷ x ≤ y ⊔ --p * top"
proof
assume "-p * x ≤ y"
thus "x ≤ y ⊔ --p * top"
by (smt (verit, ccfv_SIG) case_split_left eq_refl le_supI1 le_supI2 mult_right_isotone tests_dual.sba_dual.top_def top_greatest)
next
assume "x ≤ y ⊔ --p * top"
hence "-p * x ≤ -p * y"
by (metis sup_bot_right mult_assoc tests_dual.sup_complement mult_left_zero mult_right_isotone test_mult_right_distr_sup)
thus "-p * x ≤ y"
by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least order_trans)
qed
lemma post_pre_left_isotone:
"x ≤ y ⟹ x«-q ≤ y«-q"
by (smt order_refl order_trans pre_closed pre_post_galois)
lemma pre_left_sub_dist:
"x«-q ≤ x⊔y«-q"
by (simp add: post_pre_left_isotone)
lemma pre_post_left_isotone:
"-p ≤ -q ⟹ -p⊣-r ≤ -q⊣-r"
using order_lesseq_imp pre_post_galois by blast
lemma pre_post_left_sub_dist:
"-p⊣-r ≤ -p⊔-q⊣-r"
by (metis sup_ge1 tests_dual.inf_closed pre_post_left_isotone)
lemma pre_post_left_sup_dist:
"-p*-q⊣-r ≤ -p⊣-r"
by (metis tests_dual.upper_bound_left pre_post_left_isotone sub_mult_closed)
lemma pre_pre_post:
"(x«-p)⊣-p ≤ x"
by (metis order_refl pre_closed pre_post_galois)
lemma pre_post_pre:
"-p ≤ (-p⊣-q)«-q"
by (simp add: pre_post_galois)
lemma pre_post_zero_top:
"bot⊣-q = bot"
using bot_least order.eq_iff pre_post_galois tests_dual.sba_dual.sub_bot_def by blast
lemma pre_post_pre_one:
"(1⊣-q)«-q = 1"
by (metis order.eq_iff pre_below_one pre_post_pre tests_dual.sba_dual.top_double_complement)
lemma pre_post_right_antitone:
"-p ≤ -q ⟹ -r⊣-q ≤ -r⊣-p"
using order_lesseq_imp pre_iso pre_post_galois by blast
lemma pre_post_right_sub_dist:
"-r⊣-p⊔-q ≤ -r⊣-p"
by (metis sup_ge1 tests_dual.inf_closed pre_post_right_antitone)
lemma pre_post_right_sup_dist:
"-r⊣-p ≤ -r⊣-p*-q"
by (metis tests_dual.upper_bound_left pre_post_right_antitone sub_mult_closed)
lemma pre_top:
"top«-q = 1"
using order.eq_iff pre_below_one pre_post_galois tests_dual.sba_dual.one_def top_greatest by blast
lemma pre_mult_top_increasing:
"-p ≤ -p*top«-q"
using pre_import_equiv pre_top tests_dual.sub_bot_least by auto
lemma pre_post_below_mult_top:
"-p⊣-q ≤ -p*top"
using pre_import_equiv pre_post_galois by auto
lemma pre_post_import_complement:
"--p*(-p⊣-q) = bot"
proof -
have "--p*(-p⊣-q) ≤ --p*(-p*top)"
by (simp add: mult_right_isotone pre_post_below_mult_top)
thus ?thesis
by (metis mult_assoc mult_left_zero sub_comm tests_dual.top_def order.antisym bot_least)
qed
lemma pre_post_import_same:
"-p*(-p⊣-q) = -p⊣-q"
proof -
have "-p⊣-q = -p*(-p⊣-q) ⊔ --p*(-p⊣-q)"
by (metis mult_left_one mult_right_dist_sup tests_dual.inf_complement)
thus ?thesis
using pre_post_import_complement by auto
qed
lemma pre_post_export:
"-p⊣-q = -p*(1⊣-q)"
proof (rule order.antisym)
show "-p⊣-q ≤ -p*(1⊣-q)"
by (metis tests_dual.sub_bot_least pre_import_equiv pre_post_galois pre_post_pre_one)
next
have 1: "-p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
by (simp add: pre_post_galois)
have "--p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
by (simp add: le_supI2 pre_post_galois pre_post_below_mult_top)
hence "-p ⊔ --p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
using 1 le_supI by blast
hence "1 ≤ ((-p⊣-q) ⊔ --p*top)«-q"
by simp
hence "1⊣-q ≤ (-p⊣-q) ⊔ --p*top"
using pre_post_galois tests_dual.sba_dual.one_def by blast
thus "-p*(1⊣-q) ≤ -p⊣-q"
by (simp add: shunting_top)
qed
lemma pre_post_seq_associative:
"-r*(-p⊣-q) = -r*-p⊣-q"
by (metis pre_post_export tests_dual.sub_sup_closed mult_assoc)
lemma pre_post_left_import_mult:
"-r*(-p⊣-q) = -r*(-r*-p⊣-q)"
by (metis mult_assoc tests_dual.sup_idempotent pre_post_seq_associative)
lemma seq_pre_post_sub_associative:
"-r*(-p⊣-q) ≤ --r⊔-p⊣-q"
by (metis le_supI1 pre_post_left_sub_dist sup_commute shunting_top)
lemma pre_post_left_import_sup:
"-r*(-p⊣-q) = -r*(--r⊔-p⊣-q)"
by (metis tests_dual.sba_dual.sub_sup_closed pre_post_seq_associative tests_dual.sup_complement_intro)
lemma pre_post_left_dist_sup:
"-p⊔-q⊣-r = (-p⊣-r) ⊔ (-q⊣-r)"
by (metis mult_right_dist_sup tests_dual.inf_closed pre_post_export)
lemma pre_post_reflexive:
"-p⊣-p ≤ 1"
using pre_one_increasing pre_post_galois by auto
lemma pre_post_compose:
"-q ≤ -r ⟹ -p⊣-s ≤ (-p⊣-q)*(-r⊣-s)"
by (meson pre_compose pre_post_galois pre_post_pre pre_post_right_antitone)
lemma pre_post_compose_1:
"-p⊣-r ≤ (-p⊣-q)*(-q⊣-r)"
by (simp add: pre_post_compose)
lemma pre_post_compose_2:
"(-p⊣-p)*(-p⊣-q) = -p⊣-q"
using order.eq_iff mult_left_isotone pre_post_compose_1 pre_post_reflexive by fastforce
lemma pre_post_compose_3:
"(-p⊣-q)*(-q⊣-q) = -p⊣-q"
by (metis order.antisym mult_right_isotone mult_1_right pre_post_compose_1 pre_post_reflexive)
lemma pre_post_compose_4:
"(-p⊣-p)*(-p⊣-p) = -p⊣-p"
by (simp add: pre_post_compose_3)
lemma pre_post_one_one:
"x«1 = 1 ⟷ 1⊣1 ≤ x"
using order.eq_iff pre_below_one pre_post_galois tests_dual.sub_bot_def by force
lemma pre_one_right:
"-p«1 = -p"
by (metis order.antisym mult_1_right one_def tests_dual.inf_complement pre_left_sub_dist pre_mult_top_increasing pre_one pre_seq pre_test_promote pre_top)
lemma pre_pre_one:
"x«-q = x*-q«1"
by (metis one_def pre_one_right pre_seq)
subclass precondition_test_diamond
apply unfold_locales
using tests_dual.sba_dual.sub_inf_def pre_one_right pre_pre_one by auto
end
class havoc_dual =
fixes Hd :: "'a"
class idempotent_left_semiring_Hd = bounded_idempotent_left_semiring + havoc_dual +
assumes Hd_total: "Hd * top = top"
assumes Hd_least: "x * top = top ⟶ Hd ≤ x"
begin
lemma Hd_least_total:
"x * top = top ⟷ Hd ≤ x"
by (metis Hd_least Hd_total order.antisym mult_left_isotone top_greatest)
lemma Hd_reflexive:
"Hd ≤ 1"
by (simp add: Hd_least)
lemma Hd_transitive:
"Hd = Hd * Hd"
by (simp add: Hd_least Hd_total order.antisym coreflexive_transitive total_mult_closed)
end
class pre_post_spec_least_Hd = idempotent_left_semiring_Hd + pre_post_spec_least +
assumes pre_one_mult_top: "(x«1)*top = x*top"
begin
lemma Hd_pre_one:
"Hd«1 = 1"
by (metis Hd_total pre_seq pre_top)
lemma pre_post_below_Hd:
"1⊣1 ≤ Hd"
using Hd_pre_one pre_post_one_one by auto
lemma Hd_pre_post:
"Hd = 1⊣1"
by (metis Hd_least Hd_pre_one Hd_total order.eq_iff pre_one_mult_top pre_post_one_one)
lemma top_left_zero:
"top*x = top"
by (metis mult_assoc mult_left_one mult_left_zero pre_closed pre_one_mult_top pre_seq pre_top)
lemma test_dual_test:
"(-p⊔--p*top)*-p = -p⊔--p*top"
by (simp add: top_left_zero mult_right_dist_sup mult_assoc)
lemma pre_zero_mult_top:
"(x«bot)*top = x*bot"
by (metis mult_assoc mult_left_zero one_def pre_one_mult_top pre_seq pre_bot)
lemma pre_one_mult_Hd:
"(x«1)*Hd ≤ x"
by (metis Hd_pre_post one_def pre_closed pre_post_export pre_pre_post)
lemma Hd_mult_pre_one:
"Hd*(x«1) ≤ x"
proof -
have 1: "-(x«1)*Hd*(x«1) ≤ x"
by (metis Hd_pre_post le_iff_sup mult_left_isotone pre_closed pre_one_right pre_post_export pre_pre_post sup_commute sup_monoid.add_0_right tests_dual.sba_dual.one_def tests_dual.top_def)
have "(x«1)*Hd*(x«1) ≤ x"
by (metis mult_isotone mult_1_right one_def pre_below_one pre_one_mult_Hd)
thus ?thesis
using 1 by (metis case_split_left pre_closed reflexive_one_closed tests_dual.sba_dual.one_def tests_dual.sba_dual.top_def mult_assoc)
qed
lemma pre_post_one_def_1:
assumes "1 ≤ x«-q"
shows "Hd*(-q⊔--q*top) ≤ x"
proof -
have "Hd*(-q⊔--q*top) ≤ x*-q*(-q⊔--q*top)"
by (metis assms Hd_pre_post order.antisym pre_below_one pre_post_one_one pre_pre_one mult_left_isotone)
thus ?thesis
by (metis mult_assoc tests_dual.sup_complement mult_left_sub_dist_sup_left mult_left_zero mult_1_right tests_dual.inf_complement test_mult_right_distr_sup order_trans)
qed
lemma pre_post_one_def:
"1⊣-q = Hd*(-q⊔--q*top)"
proof (rule order.antisym)
have "1 ≤ (1⊣1)*(-q⊔--q)«1"
by (metis pre_post_pre one_def mult_1_right tests_dual.inf_complement)
also have "... ≤ (1⊣1)*(-q⊔--q*top)«-q"
by (metis sup_right_isotone mult_right_isotone mult_1_right one_def post_pre_left_isotone pre_seq pre_test_promote test_dual_test top_right_mult_increasing)
finally show "1⊣-q ≤ Hd*(-q⊔--q*top)"
using Hd_pre_post pre_post_galois tests_dual.sub_bot_def by blast
next
show "Hd*(-q⊔--q*top) ≤ 1⊣-q"
by (simp add: pre_post_pre_one pre_post_one_def_1)
qed
lemma pre_post_def:
"-p⊣-q = -p*Hd*(-q⊔--q*top)"
by (simp add: pre_post_export mult_assoc pre_post_one_def)
end
end
Theory Pre_Post_Modal
section ‹Pre-Post Specifications and Modal Operators›
theory Pre_Post_Modal
imports Pre_Post Hoare_Modal
begin
class pre_post_spec_whiledo = pre_post_spec_greatest + whiledo
begin
lemma nat_test_pre_post:
"nat_test t s ⟹ -q ≤ s ⟹ (∀n . x ≤ t n*-p*-q⊣(pSum t n*-q)) ⟹ -p⋆x ≤ -q⊣--p*-q"
by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)
lemma nat_test_pre_post_2:
"nat_test t s ⟹ -r ≤ s ⟹ (∀n . x ≤ t n*-p⊣(pSum t n)) ⟹ -p⋆x ≤ -r⊣1"
by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre_2 one_def pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)
end
class pre_post_spec_hoare = pre_post_spec_whiledo + hoare_calculus_sound
begin
lemma pre_post_while:
"x ≤ -p*-q⊣-q ⟶ -p⋆x ≤ aL*-q⊣-q"
by (smt aL_test pre_post_galois sub_mult_closed while_soundness)
text ‹Theorem 43.1›
lemma while_soundness_3:
"test_seq t ⟹ -q ≤ Sum t ⟹ x ≤ t 0*-p*-q⊣aL*-q ⟹ (∀n>0 . x ≤ t n*-p*-q⊣pSum t n*-q) ⟹ -p⋆x ≤ -q⊣--p*-q"
by (smt (verit, del_insts) aL_test pSum_test tests_dual.inf_closed pre_post_galois sub_mult_closed test_seq_def while_soundness_1)
text ‹Theorem 43.2›
lemma while_soundness_4:
"test_seq t ⟹ -r ≤ Sum t ⟹ (∀n . x ≤ t n*-p⊣pSum t n) ⟹ -p⋆x ≤ -r⊣1"
by (smt one_def pSum_test pre_post_galois sub_mult_closed test_seq_def while_soundness_2)
end
class pre_post_spec_hoare_pc_2 = pre_post_spec_hoare + hoare_calculus_pc_2
begin
text ‹Theorem 43.3›
lemma pre_post_while_pc:
"x ≤ -p*-q⊣-q ⟶ -p⋆x ≤ -q⊣--p*-q"
by (metis pre_post_galois sub_mult_closed while_soundness_pc)
end
class pre_post_spec_hoare_pc = pre_post_spec_hoare + hoare_calculus_pc
begin
subclass pre_post_spec_hoare_pc_2 ..
lemma pre_post_one_one_top:
"1⊣1 = top"
using order.eq_iff pre_one_one pre_post_one_one by auto
end
class pre_post_spec_H = pre_post_spec_greatest + box_precondition + havoc +
assumes H_zero_2: "H * bot = bot"
assumes H_split_2: "x ≤ x * -q * top ⊔ H * --q"
begin
subclass idempotent_left_semiring_H
apply unfold_locales
apply (rule H_zero_2)
by (smt H_split_2 tests_dual.complement_bot mult_assoc mult_left_zero mult_1_right one_def)
lemma pre_post_def_iff:
"-p * x * --q ≤ Z ⟷ x ≤ Z ⊔ --p * top ⊔ H * -q"
proof (rule iffI)
assume "-p * x * --q ≤ Z"
hence "x * --q * top ≤ Z ⊔ --p * top"
by (smt (verit, ccfv_threshold) Z_left_zero_above_one case_split_left_sup mult_assoc mult_left_isotone mult_right_dist_sup mult_right_isotone top_greatest top_mult_top)
thus "x ≤ Z ⊔ --p * top ⊔ H * -q"
by (metis sup_left_isotone order_trans H_split_2 tests_dual.double_negation)
next
assume "x ≤ Z ⊔ --p * top ⊔ H * -q"
hence "-p * x * --q ≤ -p * (Z * --q ⊔ --p * top * --q ⊔ H * -q * --q)"
by (metis mult_left_isotone mult_right_dist_sup mult_right_isotone mult_assoc)
thus "-p * x * --q ≤ Z"
by (metis H_zero_2 Z_mult_decreasing sup_commute sup_bot_left mult_assoc mult_right_dist_sup mult_right_isotone order_trans test_mult_left_dist_shunt test_mult_left_sub_dist_shunt tests_dual.top_def)
qed
lemma pre_post_def:
"-p⊣-q = Z ⊔ --p*top ⊔ H*-q"
by (meson order.antisym order_refl pre_Z pre_post_galois pre_post_def_iff)
end
class pre_post_L = pre_post_spec_greatest + box_while + left_conway_semiring_L + left_kleene_conway_semiring +
assumes circ_below_L_add_star: "x⇧∘ ≤ L ⊔ x⇧⋆"
begin
text ‹a loop does not abort if its body does not abort›
text ‹this avoids abortion from all states* alternatively from states in -r if -r is an invariant›
lemma body_abort_loop:
assumes "Z = L"
and "x ≤ -p⊣1"
shows "-p⋆x ≤ 1⊣1"
proof -
have "-p * x * bot ≤ L"
by (metis assms pre_Z pre_post_galois tests_dual.sba_dual.one_def tests_dual.top_double_complement)
hence "(-p * x)⇧⋆ * bot ≤ L"
by (metis L_split le_iff_sup star_left_induct sup_bot_left)
hence "(-p * x)⇧∘ * bot ≤ L"
by (smt L_left_zero L_split sup_commute circ_below_L_add_star le_iff_sup mult_right_dist_sup)
thus ?thesis
by (metis assms(1) a_restrict mult_isotone pre_pc_Z pre_post_compose_2 pre_post_one_one tests_dual.sba_dual.one_def while_def tests_dual.sup_right_zero)
qed
end
class pre_post_spec_Hd = pre_post_spec_least + diamond_precondition + idempotent_left_semiring_Hd +
assumes d_mult_top: "d(x) * top = x * top"
begin
subclass pre_post_spec_least_Hd
apply unfold_locales
by (simp add: d_mult_top diamond_x_1 pre_def)
end
end